home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / w3 / url.el < prev    next >
Encoding:
Text File  |  1995-08-31  |  175.5 KB  |  5,096 lines
  1. ;;; url.el,v --- Uniform Resource Locator retrieval tool
  2. ;; Author: wmperry
  3. ;; Created: 1995/08/31 05:13:38
  4. ;; Version: 1.354
  5. ;; Keywords: comm, data, processes, hypermedia
  6.  
  7. ;;; LCD Archive Entry:
  8. ;;; url|William M. Perry|wmperry@spry.com|
  9. ;;; Major mode for manipulating URLs|
  10. ;;; 1995/08/31 05:13:38|1.354|Location Undetermined
  11. ;;;
  12.  
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
  15. ;;;
  16. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  17. ;;;
  18. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  19. ;;; it under the terms of the GNU General Public License as published by
  20. ;;; the Free Software Foundation; either version 2, or (at your option)
  21. ;;; any later version.
  22. ;;;
  23. ;;; GNU Emacs is distributed in the hope that it will be useful,
  24. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  25. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  26. ;;; GNU General Public License for more details.
  27. ;;;
  28. ;;; You should have received a copy of the GNU General Public License
  29. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  30. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32.  
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34. ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)   ;;;
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36.  
  37.  
  38. (require 'mm)
  39. (require 'md5)
  40. (require 'base64)
  41. (or (featurep 'efs)
  42.     (featurep 'efs-auto)
  43.     (require 'ange-ftp))
  44.  
  45.  
  46. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47. ;;; Functions that might not exist in old versions of emacs
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49. (defun url-save-error (errobj)
  50.   (save-excursion
  51.     (set-buffer (get-buffer-create " *url-error*"))
  52.     (erase-buffer))
  53.   (display-error errobj (get-buffer-create " *url-error*")))
  54.  
  55. (cond
  56.  ((fboundp 'display-warning)
  57.   (fset 'url-warn 'display-warning))
  58.  ((fboundp 'w3-warn)
  59.   (fset 'url-warn 'w3-warn))
  60.  ((fboundp 'warn)
  61.   (defun url-warn (class message &optional level)
  62.     (warn "(%s/%s) %s" class (or level 'warning) message)))
  63.  (t
  64.   (defun url-warn (class message &optional level)
  65.     (save-excursion
  66.       (set-buffer (get-buffer-create "*W3-WARNINGS*"))
  67.       (goto-char (point-max))
  68.       (save-excursion
  69.     (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
  70.       (display-buffer (current-buffer))))))
  71.  
  72.  
  73. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74. ;;; Various nntp-related macros that are useful from gnus.el, but I don't
  75. ;;; want to have to (require 'gnus) just for them
  76. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77.  
  78. (defmacro nntp-header-number (header)
  79.   "Return article number in HEADER."
  80.   (` (aref (, header) 0)))
  81.  
  82. (defmacro nntp-header-subject (header)
  83.   "Return subject string in HEADER."
  84.   (` (aref (, header) 1)))
  85.  
  86. (defmacro nntp-header-from (header)
  87.   "Return author string in HEADER."
  88.   (` (aref (, header) 2)))
  89.  
  90. (defmacro nntp-header-xref (header)
  91.   "Return xref string in HEADER."
  92.   (` (aref (, header) 3)))
  93.  
  94. (defmacro nntp-header-lines (header)
  95.   "Return lines in HEADER."
  96.   (` (aref (, header) 4)))
  97.  
  98. (defmacro nntp-header-date (header)
  99.   "Return date in HEADER."
  100.   (` (aref (, header) 5)))
  101.  
  102. (defmacro nntp-header-id (header)
  103.   "Return Id in HEADER."
  104.   (` (aref (, header) 6)))
  105.  
  106. (defmacro nntp-header-references (header)
  107.   "Return references in HEADER."
  108.   (` (aref (, header) 7)))
  109.  
  110.  
  111. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  112. ;;; Variable definitions
  113. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  114. (defconst url-version (let ((x "1.354"))
  115.             (if (string-match "Revision: \\([^ \t\n]+\\)" x)
  116.                 (substring x (match-beginning 1) (match-end 1))
  117.               x))
  118.   "Version # of URL package.")
  119.  
  120. (defvar url-current-time-string-has-args
  121.   (cond
  122.    ((string-match "XEmacs" emacs-version) t)
  123.    ((string-match "Lucid" emacs-version)
  124.     (not (string-match "Win-Emacs" emacs-version)))
  125.    ((string-match "^19" emacs-version)
  126.     t))
  127.   "Non-nil iff `current-time-string' can take an argument.")
  128.  
  129. (defvar url-current-can-be-cached t
  130.   "*Whether the current URL can be cached.")
  131.  
  132. (defvar url-current-object nil
  133.   "A parsed representation of the current url")
  134.  
  135. (defvar url-current-callback-func nil
  136.   "*The callback function for the current buffer.")
  137.  
  138. (defvar url-current-callback-data nil
  139.   "*The data to be passed to the callback function.  This should be a list,
  140. each item in the list will be an argument to the url-current-callback-func.")
  141.  
  142. (mapcar 'make-variable-buffer-local '(
  143.                       url-current-callback-data
  144.                       url-current-callback-func
  145.                       url-current-can-be-cached
  146.                       url-current-content-length
  147.                       url-current-file
  148.                       url-current-isindex
  149.                       url-current-mime-encoding
  150.                       url-current-mime-headers
  151.                       url-current-mime-type
  152.                       url-current-mime-viewer
  153.                       url-current-object
  154.                       url-current-port
  155.                       url-current-referer
  156.                       url-current-type
  157.                       url-current-user
  158.                       ))
  159.  
  160. (defvar url-default-retrieval-proc
  161.   (function (lambda (buf)
  162.           (cond
  163.            ((save-excursion (set-buffer buf)
  164.                 (and url-current-callback-func
  165.                      (fboundp url-current-callback-func)))
  166.         (save-excursion
  167.           (save-window-excursion
  168.             (set-buffer buf)
  169.             (cond
  170.              ((listp url-current-callback-data)
  171.               (apply url-current-callback-func
  172.                  url-current-callback-data))
  173.              (url-current-callback-data
  174.               (funcall url-current-callback-func
  175.                    url-current-callback-data))
  176.              (t
  177.               (funcall url-current-callback-func))))))
  178.            ((fboundp 'w3-sentinel)
  179.         (set-variable 'w3-working-buffer buf)
  180.         (w3-sentinel))
  181.            (t
  182.         (message "Retrieval for %s complete." buf)))))
  183.   "*The default action to take when an asynchronous retrieval completes.")
  184.  
  185. (defvar url-honor-refresh-requests t
  186.   "*Whether to do automatic page reloads at the request of the document
  187. author or the server via the `Refresh' header in an HTTP/1.0 response.
  188. If nil, no refresh requests will be honored.
  189. If t, all refresh requests will be honored.
  190. If non-nil and not t, the user will be asked for each refresh request.")
  191.  
  192. (defvar url-emacs-minor-version
  193.   (if (boundp 'emacs-minor-version)
  194.       (symbol-value 'emacs-minor-version)
  195.     (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
  196.     (string-to-int
  197.      (substring emacs-version
  198.             (match-beginning 1) (match-end 1)))
  199.       0))
  200.   "What minor version of emacs we are using.")
  201.  
  202. (defvar url-inhibit-mime-parsing nil
  203.   "Whether to parse out (and delete) the MIME headers from a message.")
  204.  
  205. (defvar url-forms-based-ftp nil
  206.   "*If non-nil, local and remote file access of directories will be shown
  207. as an HTML 3.0 form, allowing downloads of multiple files at once.")
  208.  
  209. (defvar url-automatic-caching nil
  210.   "*If non-nil, all documents will be automatically cached to the local
  211. disk.")
  212.  
  213. (defvar url-cache-expired
  214.   (function (lambda (t1 t2) (>= (- (car t2) (car t1)) 5)))
  215.   "*A function (`funcall'able) that takes two times as its arguments, and
  216. returns non-nil if the second time is 'too old' when compared to the first
  217. time.")
  218.  
  219. (defvar url-check-md5s nil
  220.   "*Whether to check md5s of retrieved documents or not.")
  221.  
  222. (defvar url-expected-md5 nil "What md5 we expect to see.")
  223.  
  224. (defvar url-broken-resolution nil
  225.   "*Whether to use [ange|efs]-ftp-nslookup-host.")
  226.  
  227. (defvar url-bug-address "wmperry@spry.com" "Where to send bug reports.")
  228.  
  229. (defvar url-personal-mail-address nil
  230.   "*Your full email address.  This is what is sent to HTTP/1.0 servers as
  231. the FROM field.  If not set when url-do-setup is run, it defaults to
  232. the value of url-pgp/pem-entity.")
  233.  
  234. (defvar url-mule-retrieval-coding-system (if (boundp 'MULE) *euc-japan*
  235.                       nil)
  236.   "Coding system for retrieval, used before hexified.")
  237.  
  238. (defvar url-directory-index-file "index.html"
  239.   "*The filename to look for when indexing a directory.  If this file
  240. exists, and is readable, then it will be viewed instead of
  241. automatically creating the directory listing.")
  242.  
  243. (defvar url-pgp/pem-entity nil
  244.   "*The users PGP/PEM id - usually their email address.")
  245.  
  246. (defvar url-privacy-level 'none
  247.   "*How private you want your requests to be.
  248. HTTP/1.0 has header fields for various information about the user, including
  249. operating system information, email addresses, the last page you visited, etc.
  250. This variable controls how much of this information is sent.
  251.  
  252. This should a symbol or a list.
  253. Valid values if a symbol are:
  254. none     -- Send all information
  255. low      -- Don't send the last location
  256. high     -- Don't send the email address or last location
  257. paranoid -- Don't send anything
  258.  
  259. If a list, this should be a list of symbols of what NOT to send.
  260. Valid symbols are:
  261. email    -- the email address
  262. os       -- the operating system info
  263. lastloc  -- the last location
  264.  
  265. Samples:
  266.  
  267. (setq url-privacy-level 'high)
  268. (setq url-privacy-level '(os lastloc))    ;; equivalent to 'high
  269. (setq url-privacy-level '(os))
  270. ")
  271.  
  272. (defvar url-uudecode-program "uudecode" "*The UUdecode executable.")
  273.  
  274. (defvar url-uuencode-program "uuencode" "*The UUencode executable.")
  275.  
  276. (defvar url-history-list nil "List of urls visited this session.")
  277.  
  278. (defvar url-inhibit-uncompression nil "Do decompression if non-nil.")
  279.  
  280. (defvar url-keep-history nil
  281.   "*Controls whether to keep a list of all the URLS being visited.  If
  282. non-nil, url will keep track of all the URLS visited.
  283. If eq to `t', then the list is saved to disk at the end of each emacs
  284. session.")
  285.  
  286. (defvar url-uncompressor-alist '((".z"  . "x-gzip")
  287.                 (".gz" . "x-gzip")
  288.                 (".uue" . "x-uuencoded")
  289.                 (".hqx" . "x-hqx")
  290.                 (".Z"  . "x-compress"))
  291.   "*An assoc list of file extensions and the appropriate uncompression
  292. programs for each.")
  293.  
  294. (defvar url-xterm-command "xterm -title %s -ut -e %s %s %s"
  295.   "*Command used to start an xterm window.")
  296.  
  297. (defvar url-tn3270-emulator "tn3270"
  298.   "The client to run in a subprocess to connect to a tn3270 machine.")
  299.  
  300. (defvar url-use-transparent nil
  301.   "*Whether to use the transparent package by Brian Tompsett instead of
  302. the builtin telnet functions.  Using transparent allows you to have full
  303. vt100 emulation in the telnet and tn3270 links.")
  304.  
  305. (defvar url-mail-command 'mail
  306.   "*This function will be called whenever url needs to send mail.  It should
  307. enter a mail-mode-like buffer in the current window.
  308. The commands mail-to and mail-subject should still work in this
  309. buffer, and it should use mail-header-separator if possible.")
  310.  
  311. (defvar url-local-exec-path nil
  312.   "*A list of possible locations for x-exec scripts.")
  313.  
  314. (defvar url-proxy-services nil
  315.   "*An assoc list of access types and servers that gateway them.
  316. Looks like ((\"http\" . \"url://for/proxy/server/\") ....)  This is set up
  317. from the ACCESS_proxy environment variables in url-do-setup.")
  318.  
  319. (defvar url-global-history-file nil
  320.   "*The global history file used by both Mosaic/X and the url package.
  321. This file contains a list of all the URLs you have visited.  This file
  322. is parsed at startup and used to provide URL completion.")
  323.  
  324. (defvar url-passwd-entry-func nil
  325.   "*This is a symbol indicating which function to call to read in a
  326. password.  It will be set up depending on whether you are running EFS
  327. or ange-ftp at startup if it is nil.  This function should accept the
  328. prompt string as its first argument, and the default value as its
  329. second argument.")
  330.  
  331. (defvar url-gopher-labels
  332.   '(("0" . "(TXT)")
  333.     ("1" . "(DIR)")
  334.     ("2" . "(CSO)")
  335.     ("3" . "(ERR)")
  336.     ("4" . "(MAC)")
  337.     ("5" . "(PCB)")
  338.     ("6" . "(UUX)")
  339.     ("7" . "(???)")
  340.     ("8" . "(TEL)")
  341.     ("T" . "(TN3)")
  342.     ("9" . "(BIN)")
  343.     ("g" . "(GIF)")
  344.     ("I" . "(IMG)")
  345.     ("h" . "(WWW)")
  346.     ("s" . "(SND)"))
  347.   "*An assoc list of gopher types and how to describe them in the gopher
  348. menus.  These can be any string, but HTML/HTML+ entities should be
  349. used when necessary, or it could disrupt formatting of the document
  350. later on.  It is also a good idea to make sure all the strings are the
  351. same length after entity references are removed, on a strictly
  352. stylistic level.")
  353.  
  354. (defvar url-gopher-icons
  355.   '(
  356.     ("0" . "&text.document;")
  357.     ("1" . "&folder;")
  358.     ("2" . "&index;")
  359.     ("3" . "&stop;")
  360.     ("4" . "&binhex.document;")
  361.     ("5" . "&binhex.document;")
  362.     ("6" . "&uuencoded.document;")
  363.     ("7" . "&index;")
  364.     ("8" . "&telnet;")
  365.     ("T" . "&tn3270;")
  366.     ("9" . "&binary.document;")
  367.     ("g" . "ℑ")
  368.     ("I" . "ℑ")
  369.     ("s" . "&audio;"))
  370.   "*An assoc list of gopher types and the graphic entity references to
  371. show when possible.")
  372.  
  373. (defvar url-standalone-mode nil "*Rely solely on the cache?")
  374. (defvar url-working-buffer " *URL*" "The buffer to do all the processing in.")
  375. (defvar url-current-annotation nil "URL of document we are annotating...")
  376. (defvar url-current-referer nil "Referer of this page.")
  377. (defvar url-current-content-length nil "Current content length.")
  378. (defvar url-current-file nil "Filename of current document.")
  379. (defvar url-current-isindex nil "Is the current document a searchable index?")
  380. (defvar url-current-mime-encoding nil "MIME encoding of current document.")
  381. (defvar url-current-mime-headers nil "An alist of MIME headers.")
  382. (defvar url-current-mime-type nil "MIME type of current document.")
  383. (defvar url-current-mime-viewer nil "How to view the current MIME doc.")
  384. (defvar url-current-nntp-server nil "What nntp server currently opened.")
  385. (defvar url-current-passwd-count 0 "How many times password has failed.")
  386. (defvar url-current-port nil "Port # of the current document.")
  387. (defvar url-current-server nil "Server of the current document.")
  388. (defvar url-current-user nil "Username for ftp login.")
  389. (defvar url-current-type nil "We currently in http or file mode?")
  390. (defvar url-gopher-types "0123456789+gIThws:;<"
  391.   "A string containing character representations of all the gopher types.")
  392. (defvar url-mime-separator-chars (mapcar 'identity
  393.                     (concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  394.                         "abcdefghijklmnopqrstuvwxyz"
  395.                         "0123456789'()+_,-./=?"))
  396.   "Characters allowable in a MIME multipart separator.")
  397.  
  398. (defvar url-bad-port-list
  399.   '("25" "119")
  400.   "*List of ports to warn the user about connecting to.  Defaults to just
  401. the mail and NNTP ports so you cannot be tricked into sending fake mail or
  402. forging messages by a malicious HTML document.")
  403.  
  404. (defvar url-be-anal-about-file-attributes nil
  405.   "*Whether to use HTTP/1.0 to figure out file attributes
  406. or just guess based on file extension, etc.")
  407.  
  408. (defvar url-be-asynchronous nil
  409.   "*Controls whether document retrievals over HTTP should be done in
  410. the background.  This allows you to keep working in other windows
  411. while large downloads occur.")
  412. (make-variable-buffer-local 'url-be-asynchronous)
  413.  
  414. (defvar url-request-data nil "Any data to send with the next request.")
  415.  
  416. (defvar url-request-extra-headers nil
  417.   "A list of extra headers to send with the next request.  Should be
  418. an assoc list of headers/contents.")
  419.  
  420. (defvar url-request-method nil "The method to use for the next request.")
  421.  
  422. (defvar url-mime-encoding-string nil
  423.   "String to send to the server in the Accept-encoding: field in HTTP/1.0
  424. requests.  This is created automatically from mm-content-transfer-encodings.")
  425.  
  426. (defvar url-mime-language-string "*/*"
  427.   "String to send to the server in the Accept-language: field in
  428. HTTP/1.0 requests.")
  429.  
  430. (defvar url-mime-accept-string nil
  431.   "String to send to the server in the Accept: field in HTTP/1.0 requests.
  432. This is created automatically from url-mime-viewers, after the mailcap file
  433. has been parsed.")
  434.  
  435. (defvar url-registered-protocols nil
  436.   "Internal structure - do not modify!  See `url-register-protocol'")
  437.  
  438. (defvar url-package-version "Unknown" "Version # of package using URL.")
  439.  
  440. (defvar url-package-name "Unknown" "Version # of package using URL.")
  441.  
  442. (defvar url-default-session-id nil
  443.   "The default session ID, if none is defined for the current server.
  444. This is regenerated each time `url-do-setup' is called")
  445.  
  446. (defvar url-session-id-alist nil
  447.   "An assoc list of Session-ID headers.  Keyed off of server:portnum")
  448.  
  449. (defvar url-system-type nil "What type of system we are on.")
  450. (defvar url-os-type nil "What OS we are on.")
  451.  
  452. (defvar url-max-password-attempts 5
  453.   "*Maximum number of times a password will be prompted for when a
  454. protected document is denied by the server.")
  455.  
  456. (defvar url-wais-to-mime
  457.   '(
  458.     ("WSRC" . "application/x-wais-source")     ; A database description
  459.     ("TEXT" . "text/plain")            ; plain text
  460.     )
  461.   "An assoc list of wais doctypes and their corresponding MIME
  462. content-types.")
  463.  
  464. (defvar url-waisq-prog "waisq"
  465.   "*Name of the waisq executable on this system.  This should be the
  466. waisq program from think.com's wais8-b5.1 distribution.")
  467.  
  468. (defvar url-wais-gateway-server "www.ncsa.uiuc.edu"
  469.   "*The machine name where the WAIS gateway lives.")
  470.  
  471. (defvar url-wais-gateway-port "8001"
  472.   "*The port # of the WAIS gateway.")
  473.  
  474. (defvar url-temporary-directory "/tmp" "*Where temporary files go.")
  475.  
  476. (defvar url-show-status t
  477.   "*Whether to show a running total of bytes transferred.  Can cause a
  478. large hit if using a remote X display over a slow link, or a terminal
  479. with a slow modem.")
  480.  
  481. (defvar url-using-proxy nil
  482.   "Either nil or the fully qualified proxy URL in use, e.g.
  483. http://www.domain.com/")
  484.  
  485. (defvar url-news-server nil
  486.   "*The default news server to get newsgroups/articles from if no server
  487. is specified in the URL.  Defaults to the environment variable NNTPSERVER
  488. or \"news\" if NNTPSERVER is undefined.")
  489.  
  490. (defvar url-gopher-to-mime
  491.   '((?0 . "text/plain")            ; It's a file
  492.     (?1 . "www/gopher")            ; Gopher directory
  493.     (?2 . "www/gopher-cso-search")    ; CSO search
  494.     (?3 . "text/plain")            ; Error
  495.     (?4 . "application/mac-binhex40")    ; Binhexed macintosh file
  496.     (?5 . "application/pc-binhex40")    ; DOS binary archive of some sort
  497.     (?6 . "archive/x-uuencode")        ; Unix uuencoded file
  498.     (?7 . "www/gopher-search")        ; Gopher search!
  499.     (?9 . "application/octet-stream")    ; Binary file!
  500.     (?g . "image/gif")            ; Gif file
  501.     (?I . "image/gif")            ; Some sort of image
  502.     (?h . "text/html")            ; HTML source
  503.     (?s . "audio/basic")        ; Sound file
  504.     )
  505.   "*An assoc list of gopher types and their corresponding MIME types.")
  506.  
  507. (defvar url-use-hypertext-gopher t
  508.   "*Controls how gopher documents are retrieved.
  509. If non-nil, the gopher pages will be converted into HTML and parsed
  510. just like any other page.  If nil, the requests will be passed off to
  511. the gopher.el package by Scott Snyder.  Using the gopher.el package
  512. will lose the gopher+ support, and inlined searching.")
  513.  
  514. (defvar url-global-history-completion-list nil
  515.   "Assoc-list of for global history completion.")
  516.  
  517. (defvar url-nonrelative-link
  518.   "^\\([a-zA-Z0-9+.-]+:\\)"
  519.   "A regular expression that will match an absolute URL.")
  520.  
  521. (defvar url-confirmation-func 'y-or-n-p
  522.   "*What function to use for asking yes or no functions.  Possible
  523. values are 'yes-or-no-p or 'y-or-n-p, or any function that takes a
  524. single argument (the prompt), and returns t only if a positive answer
  525. is gotten.")
  526.  
  527. (defvar url-connection-retries 5
  528.   "*# of times to try for a connection before bailing.
  529. If for some reason url-open-stream cannot make a connection to a host
  530. right away, it will sit for 1 second, then try again, up to this many
  531. tries.")
  532.  
  533. (defvar url-find-this-link nil "Link to go to within a document.")
  534.  
  535. (defvar url-show-http2-transfer t
  536.   "*Whether to show the total # of bytes, size of file, and percentage
  537. transferred when retrieving a document over HTTP/1.0 and it returns a
  538. valid content-length header.  This can mess up some people behind
  539. gateways.")
  540.  
  541. (defvar url-gateway-method 'native
  542.   "*The type of gateway support to use.
  543. Should be a symbol specifying how we are to get a connection off of the
  544. local machine.
  545.  
  546. Currently supported methods:
  547. 'program    :: Run a program in a subprocess to connect
  548.                    (examples are itelnet, an expect script, etc)
  549. 'native        :: Use the native open-network-stream in emacs
  550. 'tcp            :: Use the excellent tcp.el package from gnus.
  551.                    This simply does a (require 'tcp), then sets
  552.                    url-gateway-method to be 'native.")
  553.  
  554. (defvar url-gateway-shell-is-telnet nil
  555.   "*Whether the login shell of the remote host is telnet.")
  556.  
  557. (defvar url-gateway-program-interactive nil
  558.   "*Whether url needs to hand-hold the login program on the remote machine.")
  559.  
  560. (defvar url-gateway-handholding-login-regexp "ogin:"
  561.   "*Regexp for when to send the username to the remote process.")
  562.  
  563. (defvar url-gateway-handholding-password-regexp "ord:"
  564.   "*Regexp for when to send the password to the remote process.")
  565.  
  566. (defvar url-gateway-host-prompt-pattern "^[^#$%>;]*[#$%>;] *"
  567.   "*Regexp used to detect when the login is finished on the remote host.")
  568.  
  569. (defvar url-gateway-telnet-ready-regexp "Escape character is .*"
  570.   "*A regular expression that signifies url-gateway-telnet-program is
  571. ready to accept input.")
  572.  
  573. (defvar url-local-rlogin-prog "rlogin"
  574.   "*Program for local telnet connections.")
  575.  
  576. (defvar url-remote-rlogin-prog "rlogin"
  577.   "*Program for remote telnet connections.")
  578.  
  579. (defvar url-local-telnet-prog "telnet"
  580.   "*Program for local telnet connections.")
  581.  
  582. (defvar url-remote-telnet-prog "telnet"
  583.   "*Program for remote telnet connections.")  
  584.  
  585. (defvar url-gateway-telnet-program "itelnet"
  586.   "*Program to run in a subprocess when using gateway-method 'program.")
  587.  
  588. (defvar url-gateway-local-host-regexp nil
  589.   "*If a host being connected to matches this regexp then the
  590. connection is done natively, otherwise the process is started on
  591. `url-gateway-host' instead.")
  592.  
  593. (defvar url-use-hypertext-dired t
  594.   "*How to format directory listings.
  595.  
  596. If value is non-nil, use directory-files to list them out and
  597. transform them into a hypertext document, then pass it through the
  598. parse like any other document.
  599.  
  600. If value nil, just pass the directory off to dired using find-file.")
  601.  
  602. (defconst monthabbrev-alist
  603.   '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6)
  604.     ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))
  605.  
  606. (defvar url-default-ports '(("http"   .  "80")
  607.                 ("gopher" .  "70")
  608.                 ("telnet" .  "23")
  609.                 ("news"   . "119")
  610.                 ("https"  . "443")
  611.                 ("shttp"  .  "80"))
  612.   "An assoc list of protocols and default port #s")
  613.  
  614. (defvar url-setup-done nil "*Has setup configuration been done?")
  615.  
  616. (defvar url-source nil
  617.   "*Whether to force a sourcing of the next buffer.  This forces local
  618. files to be read into a buffer, no matter what.  Gets around the
  619. optimization that if you are passing it to a viewer, just make a
  620. symbolic link, which looses if you want the source for inlined
  621. images/etc.")
  622.  
  623.  
  624. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  625. ;;; File-name-handler-alist functions
  626. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  627. (defun url-setup-file-name-handlers ()
  628.   ;; Setup file-name handlers.
  629.   '(cond
  630.     ((not (boundp 'file-name-handler-alist))
  631.      nil)                ; Don't load if no alist
  632.     ((rassq 'url-file-handler file-name-handler-alist)
  633.      nil)                ; Don't load twice
  634.     ((and (string-match "XEmacs\\|Lucid" emacs-version)
  635.       (< url-emacs-minor-version 11)) ; Don't load in lemacs 19.10
  636.      nil)
  637.     (t
  638.      (setq file-name-handler-alist
  639.        (let ((new-handler (cons
  640.                    (concat "^/*"
  641.                        (substring url-nonrelative-link1 nil))
  642.                    'url-file-handler)))
  643.          (if file-name-handler-alist
  644.          (append (list new-handler) file-name-handler-alist)
  645.            (list new-handler)))))))
  646.   
  647. (defun url-file-handler (operation &rest args)
  648.   ;; Function called from the file-name-handler-alist routines.  OPERATION
  649.   ;; is what needs to be done ('file-exists-p, etc).  args are the arguments
  650.   ;; that would have been passed to OPERATION."
  651.   (let ((fn (get operation 'url-file-handlers))
  652.     (url (car args))
  653.     (myargs (cdr args)))
  654.     (if (= (string-to-char url) ?/)
  655.     (setq url (substring url 1 nil)))
  656.     (if fn (apply fn url myargs)
  657.       (let (file-name-handler-alist)
  658.     (apply operation url myargs)))))
  659.  
  660. (defun url-file-handler-identity (&rest args)
  661.   (car args))
  662.  
  663. (defun url-file-handler-null (&rest args)
  664.   nil)
  665.  
  666. (put 'file-directory-p 'url-file-handlers 'url-file-handler-null)
  667. (put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity)
  668. (put 'file-writable-p 'url-file-handlers 'url-file-handler-null)
  669. (put 'file-truename 'url-file-handlers 'url-file-handler-identity)
  670. (put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents)
  671. (put 'expand-file-name 'url-file-handlers 'url-expand-file-name)
  672. (put 'directory-files 'url-file-handlers 'url-directory-files)
  673. (put 'file-directory-p 'url-file-handlers 'url-file-directory-p)
  674. (put 'file-writable-p 'url-file-handlers 'url-file-writable-p)
  675. (put 'file-readable-p 'url-file-handlers 'url-file-exists)
  676. (put 'file-executable-p 'url-file-handlers 'null)
  677. (put 'file-symlink-p 'url-file-handlers 'null)
  678. (put 'file-exists-p 'url-file-handlers 'url-file-exists)
  679. (put 'copy-file 'url-file-handlers 'url-copy-file)
  680. (put 'file-attributes 'url-file-handlers 'url-file-attributes)
  681. (put 'file-name-all-completions 'url-file-handlers
  682.      'url-file-name-all-completions)
  683. (put 'file-name-completion 'url-file-handlers 'url-file-name-completion)
  684. (put 'file-local-copy 'url-file-handlers 'url-file-local-copy)
  685.  
  686.  
  687. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  688. ;;; Generic URL parsing
  689. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  690.  
  691. (defmacro url-type (urlobj)
  692.   (` (aref (, urlobj) 0)))
  693.  
  694. (defmacro url-user (urlobj)
  695.   (` (aref (, urlobj) 1)))
  696.  
  697. (defmacro url-password (urlobj)
  698.   (` (aref (, urlobj) 2)))
  699.  
  700. (defmacro url-host (urlobj)
  701.   (` (aref (, urlobj) 3)))
  702.  
  703. (defmacro url-fullness (urlobj)
  704.   (` (aref (, urlobj) 7)))
  705.  
  706. (defmacro url-port (urlobj)
  707.   (` (or (aref (, urlobj) 4)
  708.      (if (url-fullness (, urlobj))
  709.          (cdr-safe (assoc (url-type (, urlobj)) url-default-ports))))))
  710.  
  711. (defmacro url-filename (urlobj)
  712.   (` (aref (, urlobj) 5)))
  713.  
  714. (defmacro url-target (urlobj)
  715.   (` (aref (, urlobj) 6)))
  716.  
  717. (defmacro url-set-type (urlobj type)
  718.   (` (aset (, urlobj) 0 (, type))))
  719.  
  720. (defmacro url-set-user (urlobj user)
  721.   (` (aset (, urlobj) 1 (, user))))
  722.  
  723. (defmacro url-set-password (urlobj pass)
  724.   (` (aset (, urlobj) 2 (, pass))))
  725.  
  726. (defmacro url-set-host (urlobj host)
  727.   (` (aset (, urlobj) 3 (, host))))
  728.  
  729. (defmacro url-set-port (urlobj port)
  730.   (` (aset (, urlobj) 4 (, port))))
  731.  
  732. (defmacro url-set-filename (urlobj file)
  733.   (` (aset (, urlobj) 5 (, file))))
  734.  
  735. (defmacro url-set-target (urlobj targ)
  736.   (` (aset (, urlobj) 6 (, targ))))
  737.  
  738. (defmacro url-set-full (urlobj val)
  739.   (` (aset (, urlobj) 7 (, val))))
  740.   
  741. (defun url-recreate-url (urlobj)
  742.   (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "")
  743.       (if (url-user urlobj)
  744.           (concat (url-user urlobj)
  745.               (if (url-password urlobj)
  746.               (concat ":" (url-password urlobj)))
  747.               "@"))
  748.       (url-host urlobj)
  749.       (if (and (url-port urlobj)
  750.            (not (equal (url-port urlobj)
  751.                    (cdr-safe (assoc (url-type urlobj)
  752.                         url-default-ports)))))
  753.           (concat ":" (url-port urlobj)))
  754.       (or (url-filename urlobj) "/")
  755.       (if (url-target urlobj)   (concat "#" (url-target urlobj)))))
  756.         
  757. (defun url-generic-parse-url (url)
  758.   "Return a vector of the parts of URL.
  759. Format is [protocol username password hostname portnumber file reference]"
  760.   (cond
  761.    ((null url)
  762.     (make-vector 8 nil))
  763.    ((or (not (string-match url-nonrelative-link url))
  764.     (= ?/ (string-to-char url)))
  765.     (let ((retval (make-vector 8 nil)))
  766.       (url-set-filename retval url)
  767.       (url-set-full retval nil)
  768.       retval))
  769.    (t
  770.     (save-excursion
  771.       (set-buffer (get-buffer-create " *urlparse*"))
  772.       (erase-buffer)
  773.       (insert url)
  774.       (goto-char (point-min))
  775.       (set-syntax-table url-mailserver-syntax-table)
  776.       (let ((save-pos (point))
  777.         (prot nil)
  778.         (user nil)
  779.         (pass nil)
  780.         (host nil)
  781.         (port nil)
  782.         (file nil)
  783.         (refs nil)
  784.         (full nil))
  785.     (if (not (looking-at "//"))
  786.         (progn
  787.           (skip-chars-forward "a-zA-Z+.\\-")
  788.           (downcase-region save-pos (point))
  789.           (setq prot (buffer-substring save-pos (point)))
  790.           (skip-chars-forward ":")
  791.           (setq save-pos (point))))
  792.  
  793.     ;; We are doing a fully specified URL, with hostname and all
  794.     (if (looking-at "//")
  795.         (progn
  796.           (setq full t)
  797.           (forward-char 2)
  798.           (setq save-pos (point))
  799.           (skip-chars-forward "^/")
  800.           (downcase-region save-pos (point))
  801.           (setq host (buffer-substring save-pos (point)))
  802.           (if (string-match "\\([^@]+\\)@\\(.*\\)" host)
  803.           (setq user (url-match host 1)
  804.             host (url-match host 2)))
  805.           (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user))
  806.           (setq pass (url-match user 2)
  807.             user (url-match user 1)))
  808.           (if (string-match ":\\([0-9+]+\\)" host)
  809.           (setq port (url-match host 1)
  810.             host (substring host 0 (match-beginning 0))))
  811.           (setq save-pos (point))))
  812.  
  813.     ;; Now check for references
  814.     (skip-chars-forward "^#")
  815.     (setq file (buffer-substring save-pos (point)))
  816.     (if (eobp)
  817.         nil
  818.       (skip-chars-forward "#")
  819.       (setq refs (buffer-substring (point) (point-max))))
  820.     (and port (string= port (or (cdr-safe (assoc prot url-default-ports))
  821.                     ""))
  822.          (setq port nil))
  823.     (vector prot user pass host port file refs full))))))
  824.  
  825.  
  826. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  827. ;;; Utility functions
  828. ;;; -----------------
  829. ;;; Various functions used around the url code.
  830. ;;; Some of these qualify as hacks, but hey, this is elisp.
  831. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  832.  
  833. (if (fboundp 'mm-string-to-tokens)
  834.     (fset 'url-string-to-tokens 'mm-string-to-tokens)
  835.   (defun url-string-to-tokens (str &optional delim)
  836.     "Return a list of words from the string STR"
  837.     (setq delim (or delim ? ))
  838.     (let (results y)
  839.       (mapcar
  840.        (function
  841.     (lambda (x)
  842.       (cond
  843.        ((and (= x delim) y) (setq results (cons y results) y nil))
  844.        ((/= x delim) (setq y (concat y (char-to-string x))))
  845.        (t nil)))) str)
  846.       (nreverse (cons y results)))))
  847.  
  848. (defun url-days-between (date1 date2)
  849.   ;; Return the number of days between date1 and date2.
  850.   (- (url-day-number date1) (url-day-number date2)))
  851.  
  852. (defun url-day-number (date)
  853.   (let ((dat (mapcar (function (lambda (s) (and s (string-to-int s)) ))
  854.              (timezone-parse-date date))))
  855.     (timezone-absolute-from-gregorian 
  856.      (nth 1 dat) (nth 2 dat) (car dat))))
  857.  
  858. (defun url-seconds-since-epoch (date)
  859.   ;; Returns a number that says how many seconds have
  860.   ;; lapsed between Jan 1 12:00:00 1970 and DATE."
  861.   (let* ((tdate (mapcar (function (lambda (ti) (and ti (string-to-int ti))))
  862.             (timezone-parse-date date)))
  863.      (ttime (mapcar (function (lambda (ti) (and ti (string-to-int ti))))
  864.             (timezone-parse-time
  865.              (aref (timezone-parse-date date) 3))))
  866.      (edate (mapcar (function (lambda (ti) (and ti (string-to-int ti))))
  867.             (timezone-parse-date "Jan 1 12:00:00 1970")))
  868.      (tday (- (timezone-absolute-from-gregorian 
  869.            (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
  870.           (timezone-absolute-from-gregorian 
  871.            (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
  872.     (+ (nth 2 ttime)
  873.        (* (nth 1 ttime) 60)
  874.        (* (nth 0 ttime) 60 60)
  875.        (* tday 60 60 24))))
  876.  
  877. (defun url-match (s x)
  878.   ;; Return regexp match x in s.
  879.   (substring s (match-beginning x) (match-end x)))
  880.  
  881. (defun url-split (str del)
  882.   ;; Split the string STR, with DEL (a regular expression) as the delimiter.
  883.   ;; Returns an assoc list that you can use with completing-read."
  884.   (let (x y)
  885.     (while (string-match del str)
  886.       (setq y (substring str 0 (match-beginning 0))
  887.         str (substring str (match-end 0) nil))
  888.       (if (not (string-match "^[ \t]+$" y))
  889.       (setq x (cons (list y y) x))))
  890.     (if (not (equal str ""))
  891.     (setq x (cons (list str str) x)))
  892.     x))
  893.  
  894. (defun url-replace-regexp (regexp to-string)
  895.   (goto-char (point-min))
  896.   (while (re-search-forward regexp nil t)
  897.     (replace-match to-string t nil)))
  898.  
  899. (defun url-clear-tmp-buffer ()
  900.   (set-buffer (get-buffer-create url-working-buffer))
  901.   (if buffer-read-only (toggle-read-only))
  902.   (erase-buffer))  
  903.  
  904. (defun url-maybe-relative (url)
  905.   (url-retrieve (url-expand-file-name url)))
  906.  
  907. (defun url-buffer-is-hypertext (&optional buff)
  908.   "Return t if a buffer contains HTML, as near as we can guess."
  909.   (setq buff (or buff (current-buffer)))
  910.   (save-excursion
  911.     (set-buffer buff)
  912.     (let ((case-fold-search t))
  913.       (goto-char (point-min))
  914.       (re-search-forward
  915.        "<\\(TITLE\\|HEAD\\|BASE\\|H[0-9]\\|ISINDEX\\|P\\)>" nil t))))
  916.  
  917. (defun nntp-after-change-function (&rest args)
  918.   (save-excursion
  919.     (set-buffer nntp-server-buffer)
  920.     (message "Read %d bytes" (point-max))))
  921.  
  922. (defun url-percentage (x y)
  923.   (if (fboundp 'float)
  924.       (round (* 100 (/ x (float y))))
  925.     (/ (* x 100) y)))
  926.  
  927. (defun url-after-change-function (&rest args)
  928.   ;; The nitty gritty details of messaging the HTTP/1.0 status messages
  929.   ;; in the minibuffer."
  930.   (save-excursion
  931.     (set-buffer url-working-buffer)
  932.     (let (status-message)
  933.       (if url-current-content-length
  934.       nil
  935.     (goto-char (point-min))
  936.     (skip-chars-forward " \t\n")
  937.     (if (not (looking-at "HTTP/[0-9]\.[0-9]"))
  938.         (setq url-current-content-length 0)
  939.       (setq url-current-isindex
  940.         (and (re-search-forward "$\r*$" nil t) (point)))
  941.       (if (re-search-forward
  942.            "^content-type:[ \t]*\\([^\r\n]+\\)\r*$"
  943.            url-current-isindex t)
  944.           (setq url-current-mime-type (downcase
  945.                       (url-eat-trailing-space
  946.                        (buffer-substring
  947.                         (match-beginning 1)
  948.                         (match-end 1))))))
  949.       (if (re-search-forward "^content-length:\\([^\r\n]+\\)\r*$"
  950.                  url-current-isindex t)
  951.           (setq url-current-content-length
  952.             (string-to-int (buffer-substring (match-beginning 1)
  953.                              (match-end 1))))
  954.         (setq url-current-content-length nil))))
  955.       (goto-char (point-min))
  956.       (if (re-search-forward "^status:\\([^\r]*\\)" url-current-isindex t)
  957.       (progn
  958.         (setq status-message (buffer-substring (match-beginning 1)
  959.                            (match-end 1)))
  960.         (replace-match (concat "btatus:" status-message))))
  961.       (goto-char (point-max))
  962.       (cond
  963.        (status-message (url-lazy-message "%s" status-message))
  964.        ((and url-current-content-length (> url-current-content-length 1)
  965.          url-current-mime-type)
  966.     (url-lazy-message "Read %d of %d bytes (%d%%) [%s]"
  967.              (point-max) url-current-content-length
  968.              (url-percentage (point-max) url-current-content-length)
  969.              url-current-mime-type))
  970.        ((and url-current-content-length (> url-current-content-length 1))
  971.     (url-lazy-message "Read %d of %d bytes (%d%%)"
  972.              (point-max) url-current-content-length
  973.              (url-percentage (point-max)
  974.                      url-current-content-length)))
  975.        ((and (/= 1 (point-max)) url-current-mime-type)
  976.     (url-lazy-message "Read %d bytes. [%s]" (point-max)
  977.              url-current-mime-type))
  978.        ((/= 1 (point-max))
  979.     (url-lazy-message "Read %d bytes." (point-max)))
  980.        (t (url-lazy-message "Waiting for response."))))))
  981.  
  982. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  983. ;;; End hacks section
  984. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  985.  
  986. (defun url-format-directory (dir)
  987.   ;; Format the files in DIR into hypertext
  988.   (let ((files (directory-files dir nil)) file
  989.     div attr mod-time size typ)
  990.     (if (and (file-exists-p (expand-file-name url-directory-index-file dir))
  991.          (file-readable-p (expand-file-name url-directory-index-file dir)))
  992.     (save-excursion
  993.       (set-buffer url-working-buffer)
  994.       (erase-buffer)
  995.       (mm-insert-file-contents
  996.        (expand-file-name url-directory-index-file dir)))
  997.       (save-excursion
  998.     (setq div (1- (length files)))
  999.     (set-buffer url-working-buffer)
  1000.     (erase-buffer)
  1001.     (insert "<html>\n"
  1002.         " <head>\n"
  1003.         "  <title>" dir "</title>\n"
  1004.         " </head>\n"
  1005.         " <body>\n"
  1006.         "  <div1>\n"
  1007.         "   <h1 align=center> Index of " dir "</h1>\n"
  1008.         (if url-forms-based-ftp
  1009.             "   <form method=mget enctype=application/batch-fetch>\n"
  1010.           "")
  1011.         "   <pre>\n"
  1012.         "       Name                     Last modified                Size\n"
  1013.         "<hr>\n")
  1014.     (while files
  1015.       (url-lazy-message "Building directory list... (%d%%)"
  1016.                 (/ (* 100 (- div (length files))) div))
  1017.       (setq file (expand-file-name (car files) dir)
  1018.         attr (file-attributes file)
  1019.         file (car files)
  1020.         mod-time (nth 5 attr)
  1021.         size (nth 7 attr)
  1022.         typ (or (mm-extension-to-mime (url-file-extension file)) ""))
  1023.       (if (or (equal '(0 0) mod-time) ; Set to null if unknown or
  1024.                                         ; untranslateable
  1025.           (not url-current-time-string-has-args))
  1026.           (setq mod-time "Unknown                 ")
  1027.         (setq mod-time (current-time-string mod-time)))
  1028.       (if (or (equal size 0) (equal size -1) (null size))
  1029.           (setq size "   -")
  1030.         (setq size
  1031.           (cond
  1032.            ((< size 1024) (concat "   " "1K"))
  1033.            ((< size 1048576) (concat "   "
  1034.                          (int-to-string
  1035.                           (max 1 (/ size 1024))) "K"))
  1036.            (t
  1037.             (let* ((megs (max 1 (/ size 1048576)))
  1038.                (kilo (/ (- size (* megs 1048576)) 1024)))
  1039.               (concat "   "  (int-to-string megs)
  1040.                   (if (> kilo 0)
  1041.                   (concat "." (int-to-string kilo))
  1042.                 "") "M"))))))
  1043.       (cond
  1044.        ((or (equal "." (car files)) (equal "/.." (car files)) )nil)
  1045.        ((equal ".." (car files))
  1046.         (if (not (= ?/ (aref file (1- (length file)))))
  1047.         (setq file (concat file "/")))
  1048.         (insert (if url-forms-based-ftp "   " "")
  1049.             "[DIR] <a href=\"" file "/\">Parent directory</a>\n"))
  1050.        ((stringp (nth 0 attr))    ; Symbolic link handling
  1051.         (insert (if url-forms-based-ftp "   " "")
  1052.             "[LNK] <a href=\"" file "\">" (car files) "</a>"
  1053.             (make-string (max 0 (- 25 (length (car files)))) ? )
  1054.             mod-time size "\n"))
  1055.        ((nth 0 attr)        ; Directory handling
  1056.         (insert (if url-forms-based-ftp "   " "")
  1057.             "[DIR] <a href=\"" file "\">" (car files) "</a>"
  1058.             (make-string (max 0 (- 25 (length (car files)))) ? )
  1059.             mod-time size "\n"))
  1060.        ((string-match "image" typ)
  1061.         (insert (if url-forms-based-ftp
  1062.             (concat "<input type=checkbox name=file value=\""
  1063.                 (car files) "\">")
  1064.               "")
  1065.             "[IMG] <a href=\"" file "\">" (car files) "</a>"
  1066.             (make-string (max 0 (- 25 (length (car files)))) ? )
  1067.             mod-time size "\n"))
  1068.        ((string-match "application" typ)
  1069.         (insert (if url-forms-based-ftp
  1070.             (concat "<input type=checkbox name=file value=\""
  1071.                 (car files) "\">")
  1072.               "")
  1073.             "[APP] <a href=\"" file "\">" (car files) "</a>"
  1074.             (make-string (max 0 (- 25 (length (car files)))) ? )
  1075.             mod-time size "\n"))
  1076.        ((string-match "text" typ)
  1077.         (insert (if url-forms-based-ftp
  1078.             (concat "<input type=checkbox name=file value=\""
  1079.                 (car files) "\">")
  1080.               "")
  1081.             "[TXT] <a href=\"" file "\">" (car files) "</a>"
  1082.             (make-string (max 0 (- 25 (length (car files)))) ? )
  1083.             mod-time size "\n"))
  1084.        (t
  1085.         (insert (if url-forms-based-ftp
  1086.             (concat "<input type=checkbox name=file value=\""
  1087.                 (car files) "\">")
  1088.               "")
  1089.             "[UNK] <a href=\"" file "\">" (car files) "</a>"
  1090.             (make-string (max 0 (- 25 (length (car files)))) ? )
  1091.             mod-time size "\n")))
  1092.       (setq files (cdr files)))
  1093.     (insert "   </pre>\n"
  1094.         (if url-forms-based-ftp
  1095.             (concat "  <input type=submit value=\"Copy files\">\n"
  1096.                 "  </form>\n")
  1097.           "")
  1098.         "  </div1>\n"
  1099.         " </body>\n"
  1100.         "</html>\n"
  1101.         "<!-- Automatically generated by URL v" url-version
  1102.         " -->\n")))))
  1103.  
  1104. (defun url-have-visited-url (url &rest args)
  1105.   "Return non-nil iff the user has visited URL before.
  1106. The return value is a cons of the url and the date last accessed as a string"
  1107.   (assoc url url-global-history-completion-list))
  1108.  
  1109. (defun url-directory-files (url &rest args)
  1110.   "Return a list of files on a server."
  1111.   nil)
  1112.  
  1113. (defun url-file-writable-p (url &rest args)
  1114.   "Return t iff a url is writable by this user"
  1115.   nil)
  1116.  
  1117. (defun url-copy-file (url &rest args)
  1118.   "Copy a url to the specified filename."
  1119.   nil)
  1120.  
  1121. (defun url-file-directly-accessible-p (url)
  1122.   "Returns t iff the specified URL is directly accessible
  1123. on your filesystem.  (nfs, local file, etc)."
  1124.   (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url)))
  1125.      (type (url-type urlobj)))
  1126.     (and (member type '("file" "ftp"))
  1127.      (not (url-host urlobj)))))
  1128.  
  1129. ;;;###autoload
  1130. (defun url-file-attributes (url &rest args)
  1131.   "Return a list of attributes of URL.
  1132. Value is nil if specified file cannot be opened.
  1133. Otherwise, list elements are:
  1134.  0. t for directory, string (name linked to) for symbolic link, or nil.
  1135.  1. Number of links to file.
  1136.  2. File uid.
  1137.  3. File gid.
  1138.  4. Last access time, as a list of two integers.
  1139.   First integer has high-order 16 bits of time, second has low 16 bits.
  1140.  5. Last modification time, likewise.
  1141.  6. Last status change time, likewise.
  1142.  7. Size in bytes. (-1, if number is out of range).
  1143.  8. File modes, as a string of ten letters or dashes as in ls -l.
  1144.     If URL is on an http server, this will return the content-type if possible.
  1145.  9. t iff file's gid would change if file were deleted and recreated.
  1146. 10. inode number.
  1147. 11. Device number.
  1148.  
  1149. If file does not exist, returns nil."
  1150.   (and url
  1151.        (let* ((urlobj (url-generic-parse-url url))
  1152.           (type (url-type urlobj))
  1153.           (url-automatic-caching nil)
  1154.           (data nil)
  1155.           (exists nil))
  1156.      (cond
  1157.       ((equal type "http")
  1158.        (cond
  1159.         ((not url-be-anal-about-file-attributes)
  1160.          (setq data (list
  1161.              (url-file-directory-p url) ; Directory
  1162.              1        ; number of links to it
  1163.              0        ; UID
  1164.              0        ; GID
  1165.              (cons 0 0)    ; Last access time
  1166.              (cons 0 0)    ; Last mod. time
  1167.              (cons 0 0)    ; Last status time
  1168.              -1        ; file size
  1169.              (mm-extension-to-mime
  1170.               (url-file-extension (url-filename urlobj)))
  1171.              nil        ; gid would change
  1172.              0        ; inode number
  1173.              0        ; device number
  1174.              )))
  1175.         (t                ; HTTP/1.0, use HEAD
  1176.          (let ((url-request-method "HEAD")
  1177.            (url-request-data nil)
  1178.            (url-working-buffer " *url-temp*"))
  1179.            (save-excursion
  1180.          (url-retrieve url)
  1181.          (setq data (and (setq exists
  1182.                        (cdr (assoc "status"
  1183.                            url-current-mime-headers)))
  1184.                  (>= exists 200)
  1185.                  (< exists 300)
  1186.                  (list
  1187.                   (url-file-directory-p url) ; Directory
  1188.                   1    ; links to
  1189.                   0    ; UID
  1190.                   0    ; GID
  1191.                   (cons 0 0) ; Last access time
  1192.                   (cons 0 0) ; Last mod. time
  1193.                   (cons 0 0) ; Last status time
  1194.                   (or    ; Size in bytes
  1195.                    (cdr (assoc "content-length"
  1196.                            url-current-mime-headers))
  1197.                    -1)
  1198.                   (or
  1199.                    (cdr (assoc "content-type"
  1200.                            url-current-mime-headers))
  1201.                    (mm-extension-to-mime
  1202.                     (url-file-extension
  1203.                      (url-filename urlobj)))) ; content-type
  1204.                   nil    ; gid would change
  1205.                   0    ; inode number
  1206.                   0    ; device number
  1207.                   )))
  1208.          (and (not data)
  1209.               (setq data (list (url-file-directory-p url)
  1210.                        1 0 0 (cons 0 0) (cons 0 0) (cons 0 0)
  1211.                        -1 (mm-extension-to-mime
  1212.                        (url-file-extension
  1213.                         url-current-file))
  1214.                        nil 0 0)))
  1215.          (kill-buffer " *url-temp*"))))))
  1216.       ((member type '("ftp" "file"))
  1217.        (let ((fname (if (url-host urlobj)
  1218.                 (concat "/"
  1219.                     (if (url-user urlobj)
  1220.                     (concat (url-user urlobj) "@")
  1221.                       "")
  1222.                     (url-host urlobj) ":"
  1223.                     (url-filename urlobj))
  1224.               (url-filename urlobj))))
  1225.          (setq data (or (file-attributes fname) (make-list 12 nil)))
  1226.          (setcar (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr data))))))))
  1227.              (mm-extension-to-mime (url-file-extension fname)))))
  1228.       (t nil))
  1229.      data)))
  1230.  
  1231. (defun url-file-name-all-completions (file dirname &rest args)
  1232.   "Return a list of all completions of file name FILE in directory DIR.
  1233. These are all file names in directory DIR which begin with FILE."
  1234.   (if (not url-setup-done) (url-do-setup))
  1235.   (let ((tmp url-global-history-completion-list)
  1236.     (len nil)
  1237.     (comps nil))
  1238.     (setq dirname (try-completion dirname url-global-history-completion-list)
  1239.       len (length dirname))
  1240.     (while tmp
  1241.       (if (string= dirname (substring (car (car tmp)) 0
  1242.                       (min (length (car (car tmp))) len)))
  1243.       (setq comps (cons (car (car tmp)) comps)))
  1244.       (setq tmp (cdr tmp)))
  1245.     comps))
  1246.  
  1247. (defun url-file-name-completion (file dirname &rest args)
  1248.   "Complete file name FILE in directory DIR.
  1249. Returns the longest string
  1250. common to all filenames in DIR that start with FILE.
  1251. If there is only one and FILE matches it exactly, returns t.
  1252. Returns nil if DIR contains no name starting with FILE."
  1253.   (apply 'url-file-name-all-completions file dirname args))
  1254.  
  1255. (defun url-file-local-copy (file &rest args)
  1256.   "Copy the file FILE into a temporary file on this machine.
  1257. Returns the name of the local copy, or nil, if FILE is directly
  1258. accessible."
  1259.   nil)
  1260.  
  1261. (defun url-insert-file-contents (url &rest args)
  1262.   "Insert the contents of the URL in this buffer."
  1263.   (save-excursion
  1264.     (url-retrieve url))
  1265.   (insert-buffer url-working-buffer)
  1266.   (setq buffer-file-name url)
  1267.   (kill-buffer url-working-buffer))
  1268.  
  1269. (defun url-file-directory-p (url &rest args)
  1270.   "Return t iff a url points to a directory"
  1271.   (equal (substring url -1 nil) "/"))
  1272.  
  1273. (defun url-file-exists (url &rest args)
  1274.   "Return t iff a file exists."
  1275.   (let* ((urlobj (url-generic-parse-url url))
  1276.      (type (url-type urlobj))
  1277.      (exists nil))
  1278.     (cond
  1279.      ((equal type "http")        ; use head
  1280.       (let ((url-request-method "HEAD")
  1281.         (url-request-data nil)
  1282.         (url-working-buffer " *url-temp*"))
  1283.     (save-excursion
  1284.       (url-retrieve url)
  1285.       (setq exists (or (cdr
  1286.                 (assoc "status" url-current-mime-headers)) 500))
  1287.       (kill-buffer " *url-temp*")
  1288.       (setq exists (and (>= exists 200) (< exists 300))))))
  1289.      ((member type '("ftp" "file"))    ; file-attributes
  1290.       (let ((fname (if (url-host urlobj)
  1291.                (concat "/"
  1292.                    (if (url-user urlobj)
  1293.                    (concat (url-user urlobj) "@")
  1294.                  "")
  1295.                    (url-host urlobj) ":"
  1296.                    (url-filename urlobj))
  1297.              (url-filename urlobj))))
  1298.     (setq exists (file-exists-p fname))))
  1299.      (t nil))
  1300.     exists))
  1301.  
  1302. ;;;###autoload
  1303. (defun url-normalize-url (url)
  1304.   "Return a 'normalized' version of URL.  This strips out default port
  1305. numbers, etc."
  1306.   (let (type data grok retval)
  1307.     (setq data (url-generic-parse-url url)
  1308.       type (url-type data))
  1309.     (if (member type '("www" "about" "mailto" "mailserver" "info"))
  1310.     (setq retval url)
  1311.       (setq retval (url-recreate-url data)))
  1312.     retval))
  1313.  
  1314. ;;;###autoload
  1315. (defun url-buffer-visiting (url)
  1316.   "Return the name of a buffer (if any) that is visiting URL."
  1317.   (setq url (url-normalize-url url))
  1318.   (let ((bufs (buffer-list))
  1319.     (found nil))
  1320.     (if (condition-case ()
  1321.         (string-match "\\(.*\\)#" url)
  1322.       (error nil))
  1323.     (setq url (url-match url 1)))
  1324.     (while (and bufs (not found))
  1325.       (save-excursion
  1326.     (set-buffer (car bufs))
  1327.     (setq found (if (and
  1328.              (not (equal (buffer-name (car bufs))
  1329.                      url-working-buffer))
  1330.              (memq major-mode '(url-mode w3-mode))
  1331.              (equal (url-view-url t) url)) (car bufs) nil)
  1332.           bufs (cdr bufs))))
  1333.     found))
  1334.  
  1335. (defun url-file-size (url &rest args)
  1336.   "Return the size of a file in bytes, or -1 if can't be determined."
  1337.   (let* ((urlobj (url-generic-parse-url url))
  1338.      (type (url-type urlobj))
  1339.      (size -1)
  1340.      (data nil))
  1341.     (cond
  1342.      ((equal type "http")        ; use head
  1343.       (let ((url-request-method "HEAD")
  1344.         (url-request-data nil)
  1345.         (url-working-buffer " *url-temp*"))
  1346.     (save-excursion
  1347.       (url-retrieve url)
  1348.       (setq size (or (cdr
  1349.               (assoc "content-length" url-current-mime-headers))
  1350.              -1))
  1351.       (kill-buffer " *url-temp*"))))
  1352.      ((member type '("ftp" "file"))    ; file-attributes
  1353.       (let ((fname (if (url-host urlobj)
  1354.                (concat "/"
  1355.                    (if (url-user urlobj)
  1356.                    (concat (url-user urlobj) "@")
  1357.                  "")
  1358.                    (url-host urlobj) ":"
  1359.                    (url-filename urlobj))
  1360.              (url-filename urlobj))))
  1361.     (setq data (file-attributes fname)
  1362.           size (nth 7 data))))
  1363.      (t nil))
  1364.     (cond
  1365.      ((stringp size) (string-to-int size))
  1366.      ((integerp size) size)
  1367.      ((null size) -1)
  1368.      (t -1))))
  1369.  
  1370. (defun url-generate-new-buffer-name (start)
  1371.   "Create a new buffer name based on START."
  1372.   (let ((x 1)
  1373.     name)
  1374.     (if (not (get-buffer start))
  1375.     start
  1376.       (progn
  1377.     (setq name (format "%s<%d>" start x))
  1378.     (while (get-buffer name)
  1379.       (setq x (1+ x)
  1380.         name (format "%s<%d>" start x)))
  1381.     name))))
  1382.  
  1383. (defun url-generate-unique-filename (&optional fmt)
  1384.   "Generate a unique filename in url-temporary-directory"
  1385.   (if (not fmt)
  1386.       (let ((base (format "url-tmp.%d" (user-real-uid)))
  1387.         (fname "")
  1388.         (x 0))
  1389.     (setq fname (format "%s%d" base x))
  1390.     (while (file-exists-p (expand-file-name fname url-temporary-directory))
  1391.       (setq x (1+ x)
  1392.         fname (concat base (int-to-string x))))
  1393.     (expand-file-name fname url-temporary-directory))
  1394.     (let ((base (concat "url" (int-to-string (user-real-uid))))
  1395.       (fname "")
  1396.       (x 0))
  1397.       (setq fname (format fmt (concat base (int-to-string x))))
  1398.       (while (file-exists-p (expand-file-name fname url-temporary-directory))
  1399.     (setq x (1+ x)
  1400.           fname (format fmt (concat base (int-to-string x)))))
  1401.       (expand-file-name fname url-temporary-directory))))
  1402.  
  1403. (defvar url-lazy-message-time 0)
  1404.  
  1405. (defun url-lazy-message-1 (&rest args)
  1406.   "Just like `message', but is a no-op if called more than once a second.
  1407. Will not do anything if url-show-status is nil."
  1408.   (if (or (null url-show-status)
  1409.       (= url-lazy-message-time
  1410.          (setq url-lazy-message-time (nth 1 (current-time)))))
  1411.       nil
  1412.     (apply 'message args)))
  1413.  
  1414. (defun url-lazy-message-2 (&rest args)
  1415.   "Just like `message', but will not do anything if url-show-transfer-status
  1416. is nil."
  1417.   (if url-show-status
  1418.       (apply 'message args)
  1419.     nil))
  1420.  
  1421.  
  1422. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1423. ;;; Support for HTTP/1.0 MIME messages
  1424. ;;; ----------------------------------
  1425. ;;; These functions are the guts of the HTTP/0.9 and HTTP/1.0 transfer
  1426. ;;; protocol, handling access authorization, format negotiation, the
  1427. ;;; whole nine yards.
  1428. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1429. (defun url-parse-viewer-types ()
  1430.   "Create a string usable for an Accept: header from mm-mime-data"
  1431.   (let ((tmp mm-mime-data)
  1432.     mjr mnr (str ""))
  1433.     (while tmp
  1434.       (setq mnr (cdr (car tmp))
  1435.         mjr (car (car tmp))
  1436.         tmp (cdr tmp))
  1437.       (while mnr
  1438.     (if (> (+ (% (length str) 60)
  1439.           (length (concat ", " mjr "/" (car (car mnr))))) 60)
  1440.         (setq str (format "%s\r\nAccept: %s/%s" str mjr
  1441.                   (if (string= ".*" (car (car mnr))) "*"
  1442.                 (car (car mnr)))))
  1443.       (setq str (format "%s, %s/%s" str mjr
  1444.                 (if (string= ".*" (car (car mnr))) "*"
  1445.                   (car (car mnr))))))
  1446.     (setq mnr (cdr mnr))))
  1447.     (substring str 2 nil)))
  1448.  
  1449. (defun url-create-multipart-request (file-list)
  1450.   "Create a multi-part MIME request for all files in FILE-LIST"
  1451.   (let ((separator (current-time-string))
  1452.     (content "message/http-request")           
  1453.     (ref-url nil))
  1454.     (setq separator
  1455.       (concat "separator-"
  1456.           (mapconcat
  1457.            (function
  1458.             (lambda (char)
  1459.               (if (memq char url-mime-separator-chars)
  1460.               (char-to-string char) ""))) separator "")))
  1461.     (cons separator
  1462.       (concat
  1463.        (mapconcat
  1464.         (function
  1465.          (lambda (file)
  1466.            (concat "--" separator "\nContent-type: " content "\n\n"
  1467.                (url-create-mime-request file ref-url)))) file-list "\n")
  1468.        "--" separator))))
  1469.  
  1470. (defun url-create-message-id ()
  1471.   "Generate a string suitable for the Message-ID field of a request"
  1472.   (concat "<" (url-create-unique-id) "@" (system-name) ">"))
  1473.  
  1474. (defun url-create-unique-id ()
  1475.   ;; Generate unique ID from user name and current time.
  1476.   (require 'timezone)
  1477.   (let* ((date (current-time-string))
  1478.      (name (user-login-name))
  1479.      (dateinfo (and date (timezone-parse-date date)))
  1480.      (timeinfo (and date (timezone-parse-time (aref dateinfo 3)))))
  1481.     (if (and dateinfo timeinfo)
  1482.     (concat (upcase name) "."
  1483.         (aref dateinfo 0)    ; Year
  1484.         (aref dateinfo 1)    ; Month
  1485.         (aref dateinfo 2)    ; Day
  1486.         (aref timeinfo 0)    ; Hour
  1487.         (aref timeinfo 1)    ; Minute 
  1488.         (aref timeinfo 2)    ; Second
  1489.         )
  1490.       (error "Cannot understand current-time-string: %s." date))
  1491.     ))
  1492.   
  1493. (defun url-create-mime-request (fname ref-url)
  1494.   "Create a MIME request for fname, referred to by REF-URL."
  1495.   (let* ((extra-headers)
  1496.      (request nil)
  1497.      (sessionid (cdr-safe (assoc (concat url-current-server ":"
  1498.                          url-current-port)
  1499.                      url-session-id-alist)))
  1500.      (url (url-view-url t))
  1501.      (no-cache (cdr-safe (assoc "Pragma" url-request-extra-headers)))
  1502.      (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers))
  1503.            nil
  1504.          (url-get-authentication (or
  1505.                       (and (boundp 'proxy-info)
  1506.                            proxy-info)
  1507.                       url) nil 'any nil))))
  1508.     (setq no-cache (and no-cache (string-match "no-cache" no-cache)))
  1509.     (if auth
  1510.     (setq auth (concat "Authorization: " auth "\r\n")))
  1511.  
  1512.     (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil")
  1513.                        (string= ref-url "")))
  1514.     (setq ref-url nil))
  1515.  
  1516.     (if (or (memq url-privacy-level '(low high paranoid))
  1517.         (and (listp url-privacy-level)
  1518.          (memq 'lastloc url-privacy-level)))
  1519.     (setq ref-url nil))
  1520.  
  1521.     (setq extra-headers (mapconcat
  1522.              (function (lambda (x)
  1523.                      (concat (car x) ": " (cdr x))))
  1524.              url-request-extra-headers "\r\n"))
  1525.     (if (not (equal extra-headers ""))
  1526.     (setq extra-headers (concat extra-headers "\r\n")))
  1527.     (setq request
  1528.       (format
  1529.        (concat
  1530.         "%s %s HTTP/1.0\r\n"    ; The request
  1531.         "MIME-Version: 1.0\r\n"    ; Version of MIME we speaketh
  1532.         "Extension: Security/Digest\r\n"
  1533.         "Session-ID: %s\r\n"    ; This session's unique ID
  1534.         "%s"            ; Who its from
  1535.         "Accept-encoding: %s\r\n"    ; Encodings we understand
  1536.         "Accept-language: %s\r\n"     ; Languages we understand
  1537.         "Accept: %s\r\n"        ; Types we understand
  1538.         "User-Agent: %s/%s"        ; User agent
  1539.         " URL/%s (%s ; %s)\r\n"
  1540.         "Message-ID: %s\r\n"    ; Message ID #
  1541.         "%s"            ; Authorization
  1542.         "%s"            ; If-modified-since
  1543.         "%s"            ; Where we came from
  1544.         "%s"            ; Any extra headers
  1545.         "%s"            ; Any data
  1546.         "\r\n")            ; End request
  1547.        (or url-request-method "GET")
  1548.        fname
  1549.        (or sessionid url-default-session-id)
  1550.        (if url-personal-mail-address
  1551.            (concat "From: " url-personal-mail-address "\r\n")
  1552.          "")
  1553.        url-mime-encoding-string
  1554.        url-mime-language-string
  1555.        url-mime-accept-string
  1556.        url-package-name
  1557.        url-package-version
  1558.        url-version
  1559.        url-system-type
  1560.        url-os-type
  1561.        (url-create-message-id)
  1562.        (or auth "")
  1563.        (if (and url-current-time-string-has-args
  1564.             (not no-cache)
  1565.             (member url-request-method '("GET" nil)))
  1566.            (let ((tm (url-is-cached url)))
  1567.          (if tm
  1568.              (concat "If-modified-since: "
  1569.                  (url-get-normalized-date tm) "\r\n")
  1570.            ""))
  1571.          "")
  1572.        (if ref-url (concat "Referer: " ref-url "\r\n") "")
  1573.        extra-headers
  1574.        (if url-request-data
  1575.            (format "Content-length: %d\r\n\r\n%s"
  1576.                (length url-request-data) url-request-data)
  1577.          "")))
  1578.     request))
  1579.  
  1580. (defun url-setup-reload-timer (url must-be-viewing &optional time)
  1581.   ;; Set up a timer to load URL at optional TIME.  If TIME is unspecified,
  1582.   ;; default to 5 seconds.  Only loads document if MUST-BE-VIEWING is the
  1583.   ;; current URL when the timer expires."
  1584.   (or time (setq time 5))
  1585.   (let ((func
  1586.      (` (lambda ()
  1587.           (if (equal (url-view-url t) (, must-be-viewing))
  1588.           (let ((w3-reuse-buffers 'no))
  1589.             (if (equal (, url) (url-view-url t))
  1590.             (kill-buffer (current-buffer)))
  1591.             (w3-fetch (, url))))))))
  1592.     (cond
  1593.      ((featurep 'itimer)
  1594.       (start-itimer "reloader" func time))
  1595.      ((fboundp 'run-at-time)
  1596.       (run-at-time time nil func))
  1597.      (t
  1598.       (url-warn 'url "Cannot set up timer for automatic reload, sorry!")))))
  1599.  
  1600. (defun url-handle-refresh-header (reload)
  1601.   (if (and reload
  1602.        url-honor-refresh-requests
  1603.        (or (eq url-honor-refresh-requests t)
  1604.            (funcall url-confirmation-func "Honor refresh request? ")))
  1605.       (let ((uri (url-view-url t)))
  1606.     (if (string-match ";" reload)
  1607.         (progn
  1608.           (setq uri (substring reload (match-end 0) nil)
  1609.             reload (substring reload 0 (match-beginning 0)))
  1610.           (if (string-match
  1611.            "ur[li][ \t]*=[ \t]*\"*\\([^ \t\"]+\\)\"*"
  1612.            uri)
  1613.           (setq uri (url-match uri 1)))
  1614.           (setq uri (url-expand-file-name uri (url-view-url t)))))
  1615.     (url-setup-reload-timer uri (url-view-url t)
  1616.                 (string-to-int (or reload "5"))))))
  1617.  
  1618. (defun url-parse-mime-headers (&optional no-delete switch-buff)
  1619.   ;; Parse mime headers and remove them from the html
  1620.   (and switch-buff (set-buffer url-working-buffer))
  1621.   (let* ((st (point-min))
  1622.      (nd (progn
  1623.            (goto-char (point-min))
  1624.            (skip-chars-forward " \t\n")
  1625.            (if (re-search-forward "^\r*$" nil t)
  1626.            (1+ (point))
  1627.          (point-max))))
  1628.      save-pos
  1629.      status
  1630.      hname
  1631.      hvalu
  1632.      result
  1633.      )
  1634.     (narrow-to-region st (min nd (point-max)))
  1635.     (goto-char (point-min))
  1636.     (skip-chars-forward " \t\n")    ; Get past any blank crap
  1637.     (skip-chars-forward "^ \t")    ; Skip over the HTTP/xxx
  1638.     (setq status (read (current-buffer)); Quicker than buffer-substring, etc.
  1639.       result (cons (cons "status" status) result))
  1640.     (end-of-line)
  1641.     (while (not (eobp))
  1642.       (skip-chars-forward " \t\n\r")
  1643.       (setq save-pos (point))
  1644.       (skip-chars-forward "^:\n\r")
  1645.       (downcase-region save-pos (point))
  1646.       (setq hname (buffer-substring save-pos (point)))
  1647.       (skip-chars-forward ": \t ")
  1648.       (setq save-pos (point))
  1649.       (skip-chars-forward "^\n\r")
  1650.       (setq hvalu (buffer-substring save-pos (point))
  1651.         result (cons (cons hname hvalu) result)))
  1652.     (or no-delete (delete-region st (min nd (point))))
  1653.     (setq url-current-mime-type (cdr (assoc "content-type" result))
  1654.       url-current-mime-encoding (cdr (assoc "content-encoding" result))
  1655.       url-current-mime-viewer (mm-mime-info url-current-mime-type nil t)
  1656.       url-current-mime-headers result
  1657.       url-current-can-be-cached
  1658.       (not (string-match "no-cache"
  1659.                  (or (cdr-safe (assoc "pragma" result)) ""))))
  1660.     (url-handle-refresh-header (cdr-safe (assoc "refresh" result)))
  1661.     (if (and url-request-method (string= url-request-method "HEAD"))
  1662.     (setq url-current-can-be-cached nil))
  1663.     (let ((sessionid (cdr-safe (assoc "session-id" result)))
  1664.       (node (assoc (concat url-current-server ":" url-current-port)
  1665.                url-session-id-alist)))
  1666.       (if sessionid
  1667.       (if node
  1668.           (setcdr node sessionid)
  1669.         (setq url-session-id-alist
  1670.           (cons (cons (concat url-current-server ":" url-current-port)
  1671.                   sessionid) url-session-id-alist)))))
  1672.     (let ((expires (cdr-safe (assoc "expires" result))))
  1673.       (if (and expires url-current-can-be-cached (featurep 'timezone))
  1674.       (progn
  1675.         (if (string-match
  1676.          (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
  1677.              "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
  1678.                   expires)
  1679.         (setq expires (concat (url-match expires 1) " "
  1680.                       (url-match expires 2) " "
  1681.                       (url-match expires 3) " "
  1682.                       (url-match expires 4) " ["
  1683.                       (url-match expires 5) "]")))
  1684.         (setq expires
  1685.           (let ((d1 (mapcar
  1686.                  (function
  1687.                   (lambda (s) (and s (string-to-int s))))
  1688.                  (timezone-parse-date
  1689.                   (current-time-string))))
  1690.             (d2 (mapcar
  1691.                  (function (lambda (s) (and s (string-to-int s))))
  1692.                  (timezone-parse-date expires))))
  1693.             (- (timezone-absolute-from-gregorian 
  1694.             (nth 1 d1) (nth 2 d1) (car d1))
  1695.                (timezone-absolute-from-gregorian 
  1696.             (nth 1 d2) (nth 2 d2) (car d2))))
  1697.           url-current-can-be-cached (/= 0 expires)))))
  1698.     (cond
  1699.      ((= status 500)            ; Internal server error
  1700.       (setq url-current-can-be-cached nil))
  1701.      ((= status 501)            ; Facility not supported
  1702.       (setq url-current-can-be-cached nil))
  1703.      ((= status 400)            ; Bad request - syntax
  1704.       (setq url-current-can-be-cached nil))
  1705.      ((and (= status 401)        ; Unauthorized access, retry w/auth.
  1706.        (< url-current-passwd-count url-max-password-attempts))
  1707.       (setq url-current-passwd-count (1+ url-current-passwd-count))
  1708.       (let* ((y (cdr (assoc "www-authenticate" result)))
  1709.          (url (url-view-url t))
  1710.          (type (downcase (if (string-match "[ \t]" y)
  1711.                  (substring y 0 (match-beginning 0))
  1712.                    y))))
  1713.     (cond
  1714.      ((or (equal "pem" type) (equal "pgp" type))
  1715.       (if (string-match "entity=\"\\([^\"]+\\)\"" y)
  1716.           (url-fetch-with-pgp url-current-file
  1717.                   (url-match y 1) (intern type))
  1718.         (error "Could not find entity in %s!" type)))
  1719.      ((url-auth-registered type)
  1720.       (let ((args y)
  1721.         (ctr (1- (length y)))
  1722.         auth
  1723.         (url-request-extra-headers url-request-extra-headers))
  1724.         (while (/= 0 ctr)
  1725.           (if (= ?, (aref args ctr))
  1726.           (aset args ctr ?\;))
  1727.           (setq ctr (1- ctr)))
  1728.         (setq args (mm-parse-args y)
  1729.           auth (url-get-authentication url
  1730.                            (cdr-safe (assoc "realm" args))
  1731.                            type t args))
  1732.         (if auth
  1733.         (setq url-request-extra-headers
  1734.               (cons (cons "Authorization" auth)
  1735.                 url-request-extra-headers)))
  1736.         (url-retrieve url t)))
  1737.      (t
  1738.       (widen)
  1739.       (goto-char (point-max))
  1740.       (setq url-current-can-be-cached nil)
  1741.       (insert "<hr>Sorry, but I do not know how to handle " y
  1742.           " authentication.  If you'd like to write it,"
  1743.           " send it to " url-bug-address ".<hr>")))))
  1744.      ((= status 401) nil)        ; Tried too many times
  1745.      ((= status 402) nil)        ; Payment required, retry w/Chargeto:
  1746.      ((= status 403) nil)        ; Access is forbidden
  1747.      ((= status 404) nil)        ; Not found...
  1748.      ((or (= status 301)        ; Moved - retry with Location: header
  1749.       (= status 302)        ; Found - retry with Location: header
  1750.       (= status 303))        ; Method - retry with location/method
  1751.       (let ((x (url-view-url t))
  1752.         (redir (or (cdr (assoc "uri" result))
  1753.                (cdr (assoc "location" result))))
  1754.         (redirmeth (or (cdr (assoc "method" result)) url-request-method)))
  1755.     (if (and redir (string-match "\\([^ \t]+\\)[ \t]" redir))
  1756.         (setq redir (url-match redir 1)))
  1757.     (if (and redir (string-match "^<\\(.*\\)>$" redir))
  1758.         (setq redir (url-match redir 1)))
  1759.     (if (not (equal x redir))
  1760.         (let ((url-request-method redirmeth))
  1761.           (url-maybe-relative redir))
  1762.       (progn
  1763.         (goto-char (point-max))
  1764.         (insert "<hr>Error!  This URL tried to redirect me to itself!<P>"
  1765.             "Please notify the server maintainer.")))))
  1766.      ((= status 304)            ; Cached document is newer
  1767.       (message "Extracting from cache...")
  1768.       (url-extract-from-cache (url-create-cached-filename (url-view-url t))))
  1769.      ((= status 204)            ; No response - leave old document
  1770.       (kill-buffer url-working-buffer))
  1771.      (t nil))                ; All others indicate success
  1772.     (widen)
  1773.     status))
  1774.  
  1775. (defun url-lf-to-crlf (str)
  1776.   ;; Convert all linefeeds to carriage-return-line-feed pairs in string STR
  1777.   (mapconcat (function
  1778.           (lambda (x)
  1779.         (if (= x 10) "\r\n" (char-to-string x)))) str ""))         
  1780.  
  1781. (defun url-mime-response-p (&optional switch-buff)
  1782.   ;; Determine if the current buffer is a MIME response
  1783.   (and switch-buff (set-buffer url-working-buffer))
  1784.   (goto-char (point-min))
  1785.   (skip-chars-forward " \t\n")
  1786.   (and (looking-at "^HTTP/.+")))
  1787.  
  1788.  
  1789. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1790. ;;; UUencoding
  1791. ;;; ----------
  1792. ;;; These functions are needed for the (RI)PEM encoding.  PGP can
  1793. ;;; handle binary data, but (RI)PEM requires that it be uuencoded
  1794. ;;; first, or it will barf severely.  How rude.
  1795. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1796. (defun url-uuencode-buffer (&optional buff)
  1797.   "UUencode buffer BUFF, with a default of the current buffer."
  1798.   (setq buff (or buff (current-buffer)))
  1799.   (save-excursion
  1800.     (set-buffer buff)
  1801.     (url-lazy-message "UUencoding...")
  1802.     (call-process-region (point-min) (point-max)
  1803.              url-uuencode-program t t nil "url-temp-file")
  1804.     (url-lazy-message "UUencoding... done.")))
  1805.  
  1806. (defun url-uudecode-buffer (&optional buff)
  1807.   "UUdecode buffer BUFF, with a default of the current buffer."
  1808.   (setq buff (or buff (current-buffer)))
  1809.   (let ((newname (url-generate-unique-filename)))
  1810.     (save-excursion
  1811.       (set-buffer buff)
  1812.       (goto-char (point-min))
  1813.       (re-search-forward "^begin [0-9][0-9][0-9] \\(.*\\)$" nil t)
  1814.       (replace-match (concat "begin 600 " newname))
  1815.       (url-lazy-message "UUdecoding...")
  1816.       (call-process-region (point-min) (point-max) url-uudecode-program)
  1817.       (url-lazy-message "UUdecoding...")
  1818.       (erase-buffer)
  1819.       (mm-insert-file-contents newname)
  1820.       (url-lazy-message "UUdecoding... done.")
  1821.       (condition-case ()
  1822.       (delete-file newname)
  1823.     (error nil)))))
  1824.       
  1825. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1826. ;;; Decoding PGP/PEM responses
  1827. ;;; --------------------------
  1828. ;;; A PGP/PEM encrypted/signed response contains all the real headers,
  1829. ;;; so this is just a quick decrypt-then-reparse hack.
  1830. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1831. (defun url-decode-pgp/pem (arg)
  1832.   "Decode a pgp/pem response from an HTTP/1.0 server.
  1833. This expects the decoded message to contain all the necessary HTTP/1.0 headers
  1834. to correctly act on the decoded message (new content-type, etc)."
  1835.   (mc-decrypt-message)
  1836.   (url-parse-mime-headers))
  1837.  
  1838. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1839. ;;; PGP/PEM Encryption
  1840. ;;; ------------------
  1841. ;;; This implements the highly secure PGP/PEM encrypted requests, as
  1842. ;;; specified by NCSA and CERN.
  1843. ;;;
  1844. ;;; The complete online spec of this scheme was done by Tony Sanders
  1845. ;;; <sanders@bsdi.com>, and can be seen at
  1846. ;;; http://www.bsdi.com/HTTP:TNG/ripem-http.txt
  1847. ;;;
  1848. ;;; This section of code makes use of the EXCELLENT mailcrypt.el
  1849. ;;; package by Jin S Choi (jsc@mit.edu)
  1850. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1851.  
  1852. (defun url-public-key-exists (entity scheme)
  1853.   "Return t iff a key for ENTITY exists using public key system SCHEME.
  1854. ENTITY is the username/hostname combination we are checking for.
  1855. SCHEME is a symbol representing what public key encryption program to use.
  1856.        Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are
  1857.        recognized."
  1858.   (let (retval)
  1859.     (save-excursion
  1860.       (cond
  1861.        ((eq 'pgp scheme)            ; PGP encryption
  1862.     (set-buffer (get-buffer-create " *keytmp*"))
  1863.     (erase-buffer)
  1864.     (call-process mc-pgp-path nil t nil "+batchmode" "-kxaf" entity)
  1865.     (goto-char (point-min))
  1866.     (setq retval (search-forward mc-pgp-key-begin-line nil t)))
  1867.        ((eq 'pem scheme)            ; PEM encryption
  1868.     (set-buffer (find-file-noselect mc-ripem-pubkeyfile))
  1869.     (goto-char (point-min))
  1870.     (setq retval (search-forward entity nil t)))
  1871.        (t
  1872.     (url-warn 'security
  1873.           (format
  1874.            "Bad value for SCHEME in url-public-key-exists %s"
  1875.            scheme))))
  1876.       (kill-buffer (current-buffer)))
  1877.     retval))
  1878.  
  1879. (defun url-get-server-keys (entity &optional scheme)
  1880.   "Make sure the key for ENTITY exists using SCHEME.
  1881. ENTITY is the username/hostname combination to get the info for.  
  1882.        This should be a string you could pass to 'finger'.
  1883. SCHEME is a symbol representing what public key encryption program to use.
  1884.        Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are
  1885.        recognized."
  1886.   (or scheme (setq scheme mc-default-scheme))
  1887.   (save-excursion
  1888.     (cond
  1889.      ((url-public-key-exists entity scheme) nil)
  1890.      (t
  1891.       (string-match "\\([^@]+\\)@\\(.*\\)" entity)
  1892.       (let ((url-working-buffer " *url-get-keys*"))
  1893.     (url-retrieve (format "gopher://%s:79/0%s/w" (url-match entity 1)
  1894.                  (url-match entity 2)))
  1895.     (mc-snarf-keys)
  1896.     (kill-buffer url-working-buffer))))))
  1897.    
  1898. (defun url-fetch-with-pgp (url recipient type)
  1899.   "Retrieve a document with public-key authentication.
  1900.       URL is the url to request from the server.
  1901. RECIPIENT is the server's entity name (usually webmaster@host)
  1902.      TYPE is a symbol representing what public key encryption program to use.
  1903.           Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are
  1904.           recognized."
  1905.   (or noninteractive (require 'mailcrypt))
  1906.   (let ((request (url-create-mime-request url "PGP-Redirect"))
  1907.     (url-request-data nil)
  1908.     (url-request-extra-headers nil))
  1909.     (save-excursion
  1910.       (url-get-server-keys recipient type)
  1911.       (set-buffer (get-buffer-create " *url-encryption*"))
  1912.       (erase-buffer)
  1913.       (insert "\n\n" mail-header-separator "\n" request)
  1914.       (mc-encrypt-message recipient type)
  1915.       (goto-char (point-min))
  1916.       (if (re-search-forward (concat "\n" mail-header-separator "\n") nil t)
  1917.       (delete-region (point-min) (point)))
  1918.       (setq url-request-data (buffer-string)
  1919.         url-request-extra-headers
  1920.         (list (cons "Authorized" (format "%s entity=\"%s\""
  1921.                          (cond
  1922.                           ((eq type 'pgp) "PGP")
  1923.                           ((eq type 'pem) "PEM"))
  1924.                          url-pgp/pem-entity))
  1925.           (cons "Content-type" (format "application/x-www-%s-reply"
  1926.                            (cond
  1927.                         ((eq type 'pgp) "pgp")
  1928.                         ((eq type 'pem) "pem")))))))
  1929.     (kill-buffer " *url-encryption*")
  1930.     (url-retrieve (url-expand-file-name "/") t)))
  1931.      
  1932.  
  1933. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1934. ;;; Gopher and Gopher+ support
  1935. ;;; --------------------------
  1936. ;;; Here come a few gross hacks that I call gopher and gopher+ support
  1937. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1938. (defun url-convert-ask-to-form (ask)
  1939.   ;; Convert a Gopher+ ASK block into a form.  Returns a string to be
  1940.   ;; inserted into a buffer to create the form."
  1941.   (let ((form (concat "<form enctype=application/gopher-ask-block\n"
  1942.               "      method=\"GOPHER-ASK\">\n"
  1943.               " <ul plain>\n"))
  1944.     (type "")
  1945.     (x 0)
  1946.     (parms ""))
  1947.     (while (string-match "^\\([^:]+\\): +\\(.*\\)" ask)
  1948.       (setq parms (url-match ask 2)
  1949.         type (url-strip-leading-spaces (downcase (url-match ask 1)))
  1950.         x (1+ x)
  1951.         ask (substring ask (if (= (length ask) (match-end 0))
  1952.                    (match-end 0) (1+ (match-end 0))) nil))
  1953.       (cond
  1954.        ((string= "note" type) (setq form (concat form parms)))
  1955.        ((or (string= "ask" type)
  1956.         (string= "askf" type)
  1957.         (string= "choosef" type))
  1958.     (setq parms (url-string-to-tokens parms ?\t)
  1959.           form (format "%s\n<li>%s<input name=\"%d\" value=\"%s\">"
  1960.                form (or (nth 0 parms) "Text:")
  1961.                x (or (nth 1 parms) ""))))
  1962.        ((string= "askp" type)
  1963.     (setq parms (mapcar 'car (nreverse (url-split parms "\t")))
  1964.           form (format
  1965.             "%s\n<li>%s<input name=\"%d\" type=\"password\" value=\"%s\">"
  1966.             form               ; Earlier string
  1967.             (or (nth 0 parms) "Password:") ; Prompt
  1968.             x                   ; Name
  1969.             (or (nth 1 parms) "")        ; Default value
  1970.             )))
  1971.        ((string= "askl" type)
  1972.     (setq parms (url-string-to-tokens parms ?\t)
  1973.           form (format "%s\n<li>%s<textarea name=\"%d\">%s</textarea>"
  1974.                form             ; Earlier string
  1975.                (or (nth 0 parms) "") ; Prompt string
  1976.                x             ; Name
  1977.                (or (nth 1 parms) "") ; Default value
  1978.                )))
  1979.        ((or (string= "select" type)
  1980.         (string= "choose" type))
  1981.     (setq parms (url-string-to-tokens parms ?\t)
  1982.           form (format "%s\n<li>%s<select name=\"%d\">" form (car parms) x)
  1983.           parms (cdr parms))
  1984.     (if (null parms) (setq parms (list "Yes" "No")))
  1985.     (while parms
  1986.       (setq form (concat form "<option>" (car parms) "\n")
  1987.         parms (cdr parms)))
  1988.     (setq form (concat form "</select>")))))
  1989.     (concat form "\n<li><input type=\"SUBMIT\""
  1990.         " value=\"Submit Gopher+ Ask Block\"></ul></form>")))
  1991.  
  1992. (defun url-grok-gopher-line ()
  1993.   "Return a list of link attributes from a gopher string.  Order is:
  1994. title, type, selector string, server, port, gopher-plus?"
  1995.   (let (type selector server port gopher+ st nd)
  1996.     (beginning-of-line)
  1997.     (setq st (point))
  1998.     (end-of-line)
  1999.     (setq nd (point))
  2000.     (save-excursion
  2001.       (mapcar (function
  2002.            (lambda (var)
  2003.          (goto-char st)
  2004.          (skip-chars-forward "^\t\n" nd)
  2005.          (set-variable var (buffer-substring st (point)))
  2006.          (setq st (1+ (point)))))
  2007.           '(type selector server port))
  2008.       (setq gopher+ (and (/= (1- st) nd) (buffer-substring st nd)))
  2009.       (list type (concat (substring type 0 1) selector) server port gopher+))))
  2010.  
  2011. (defun url-format-gopher-link (gophobj)
  2012.   ;; Insert a gopher link as an <A> tag
  2013.   (let ((title (nth 0 gophobj))
  2014.     (ref   (nth 1 gophobj))
  2015.     (type  (if (> (length (nth 0 gophobj)) 0)
  2016.            (substring (nth 0 gophobj) 0 1) ""))
  2017.     (serv  (nth 2 gophobj))
  2018.     (port  (nth 3 gophobj))
  2019.     (plus  (nth 4 gophobj))
  2020.     (desc  nil))
  2021.     (if (and (equal type "")
  2022.          (> (length title) 0))
  2023.     (setq type (substring title 0 1)))
  2024.     (setq title (and title (substring title 1 nil)))
  2025.     (setq desc (or (cdr (assoc type url-gopher-labels)) "(UNK)"))
  2026.     (cond
  2027.      ((null ref) "")
  2028.      ((equal type "8")
  2029.       (format "<LI> %s <A HREF=\"telnet://%s:%s/%s\">%s</A>\n"
  2030.           desc serv (concat port plus) ref title))
  2031.      ((equal type "T")
  2032.       (format "<LI> %s <A HREF=\"tn3270://%s:%s/%s\">%s</A>\n"
  2033.           desc serv (concat port plus) ref title))
  2034.      (t (format "<LI> %s <A METHODS=%s HREF=\"gopher://%s:%s/%s\">%s</A>\n"
  2035.         desc type serv (concat port plus)
  2036.         (url-hexify-string ref) title)))))
  2037.  
  2038. (defun url-gopher-clean-text (&optional buffer)
  2039.   "Decode text transmitted by gopher.
  2040. 0. Delete status line.
  2041. 1. Delete `^M' at end of line.
  2042. 2. Delete `.' at end of buffer (end of text mark).
  2043. 3. Delete `.' at beginning of line.   (does gopher want this?)"
  2044.   (set-buffer (or buffer url-working-buffer))
  2045.   ;; Insert newline at end of buffer.
  2046.   (goto-char (point-max))
  2047.   (if (not (bolp))
  2048.       (insert "\n"))
  2049.   ;; Delete `^M' at end of line.
  2050.   (goto-char (point-min))
  2051.   (while (re-search-forward "\r[^\n]*$" nil t)
  2052.     (replace-match ""))
  2053. ;  (goto-char (point-min))
  2054. ;  (while (not (eobp))
  2055. ;    (end-of-line)
  2056. ;    (if (= (preceding-char) ?\r)
  2057. ;       (delete-char -1))
  2058. ;    (forward-line 1)
  2059. ;    )
  2060.   ;; Delete `.' at end of buffer (end of text mark).
  2061.   (goto-char (point-max))
  2062.   (forward-line -1)                     ;(beginning-of-line)
  2063.   (while (looking-at "^\\.$")
  2064.     (delete-region (point) (progn (forward-line 1) (point)))
  2065.     (forward-line -1))
  2066.   ;; Replace `..' at beginning of line with `.'.
  2067.   (goto-char (point-min))
  2068.   ;; (replace-regexp "^\\.\\." ".")
  2069.   (while (search-forward "\n.." nil t)
  2070.     (delete-char -1))
  2071.   )
  2072.  
  2073. (defun url-parse-gopher (&optional buffer)
  2074.   (save-excursion
  2075.     (set-buffer (or buffer url-working-buffer))
  2076.     (url-replace-regexp (regexp-quote "&") "&")
  2077.     (url-replace-regexp (regexp-quote ">") ">")
  2078.     (url-replace-regexp (regexp-quote "<") "<")
  2079.     (url-replace-regexp "^\r*$\n" "")
  2080.     (url-replace-regexp "^\\.\r*$\n" "")
  2081.     (url-gopher-clean-text (current-buffer))
  2082.     (goto-char (point-max))
  2083.     (skip-chars-backward "\n\r\t ")
  2084.     (delete-region (point-max) (point))
  2085.     (insert "\n")
  2086.     (goto-char (point-min))
  2087.     (skip-chars-forward " \t\n")
  2088.     (delete-region (point-min) (point))
  2089.     (let* ((len (count-lines (point-min) (point-max)))
  2090.        (objs nil)
  2091.        (i 0))
  2092.       (while (not (eobp))
  2093.     (setq objs (cons (url-grok-gopher-line) objs)
  2094.           i (1+ i))
  2095.     (url-lazy-message "Converting gopher listing... %d/%d (%d%%)"
  2096.               i len (url-percentage i len))
  2097.                         
  2098.     (forward-line 1))
  2099.       (setq objs (nreverse objs))
  2100.       (erase-buffer)
  2101.       (insert "<title>"
  2102.           (cond
  2103.            ((or (string= "" url-current-file)
  2104.             (string= "1/" url-current-file)
  2105.             (string= "1" url-current-file))
  2106.         (concat "Gopher root at " url-current-server))
  2107.            ((string-match (format "^[%s]+/" url-gopher-types)
  2108.                   url-current-file)
  2109.         (substring url-current-file 2 nil))
  2110.            (t url-current-file))
  2111.           "</title><ol>"
  2112.           (mapconcat 'url-format-gopher-link objs "")
  2113.           "</ol>"))))
  2114.  
  2115. (defun url-gopher-retrieve (host port selector &optional wait-for)
  2116.   ;; Fetch a gopher object and don't mess with it at all
  2117.   (let ((proc (url-open-stream "*gopher*" url-working-buffer
  2118.                   host (if (stringp port) (string-to-int port)
  2119.                      port)))
  2120.     (len nil)
  2121.     (parsed nil))
  2122.     (url-clear-tmp-buffer)
  2123.     (setq url-current-file selector
  2124.       url-current-port port
  2125.       url-current-server host
  2126.       url-current-type "gopher")
  2127.     (if (> (length selector) 0)
  2128.     (setq selector (substring selector 1 nil)))
  2129.     (if (stringp proc)
  2130.     (message "%s" proc)
  2131.       (save-excursion
  2132.     (process-send-string proc (concat selector "\r\n"))
  2133.     (while (and (or (not wait-for)
  2134.             (progn
  2135.               (goto-char (point-min))
  2136.               (not (re-search-forward wait-for nil t))))
  2137.             (memq (url-process-status proc) '(run open)))
  2138.       (if (not parsed)
  2139.           (cond
  2140.            ((and (eq ?+ (char-after 1))
  2141.              (memq (char-after 2)
  2142.                (list ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
  2143.         (setq parsed (copy-marker 2)
  2144.               len (read parsed))
  2145.         (delete-region (point-min) parsed))
  2146.            ((and (eq ?+ (char-after 1))
  2147.              (eq ?- (char-after 2)))
  2148.         (setq len nil
  2149.               parsed t)
  2150.         (goto-char (point-min))
  2151.         (delete-region (point-min) (progn
  2152.                          (end-of-line)
  2153.                          (point))))
  2154.            ((and (eq ?- (char-after 1))
  2155.              (eq ?- (char-after 2)))
  2156.         (setq parsed t
  2157.               len nil)
  2158.         (goto-char (point-min))
  2159.         (delete-region (point-min) (progn
  2160.                          (end-of-line)
  2161.                          (point))))))
  2162.       (if len (url-lazy-message "Read %d of %d bytes (%d%%)" (point-max)
  2163.                     len
  2164.                     (url-percentage (point-max) len))
  2165.         (url-lazy-message "Read %d bytes." (point-max)))
  2166.       (url-accept-process-output proc))
  2167.     (condition-case ()
  2168.         (url-kill-process proc)
  2169.       (error nil))
  2170.     (url-replace-regexp "\n*Connection closed.*\n*" "")
  2171.     (url-replace-regexp "\n*Process .*gopher.*\n*" "")
  2172.     (while (looking-at "\r") (delete-char 1))))))
  2173.  
  2174. (defun url-do-gopher-cso-search (descr)
  2175.   ;; Do a gopher CSO search and return a plaintext document
  2176.   (let ((host (nth 0 descr))
  2177.     (port (nth 1 descr))
  2178.     (file (nth 2 descr))
  2179.     search-type search-term)
  2180.     (string-match "search-by=\\([^&]+\\)" file)
  2181.     (setq search-type (url-match file 1))
  2182.     (string-match "search-term=\\([^&]+\\)" file)
  2183.     (setq search-term (url-match file 1))
  2184.     (url-gopher-retrieve host port (format "2query %s=%s"
  2185.                       search-type search-term) "^[2-9]")
  2186.     (goto-char (point-min))
  2187.     (url-replace-regexp "^-[0-9][0-9][0-9]:[0-9]*:" "")
  2188.     (url-replace-regexp "^[^15][0-9][0-9]:.*" "")
  2189.     (url-replace-regexp "^[15][0-9][0-9]:\\(.*\\)" "<H1>\\1</H1> <PRE>")
  2190.     (goto-char (point-min))
  2191.     (insert "<title>Results of CSO search</title>\n"
  2192.         "<h1>" search-type " = " search-term "</h1>\n")
  2193.     (goto-char (point-max))
  2194.     (insert "</pre>")))
  2195.  
  2196. (defun url-do-gopher (descr)
  2197.   ;; Fetch a gopher object
  2198.   (let ((host (nth 0 descr))
  2199.     (port (nth 1 descr))
  2200.     (file (nth 2 descr))
  2201.     (type (nth 3 descr))
  2202.     (extr (nth 4 descr))
  2203.     parse-gopher)
  2204.     (cond
  2205.      ((and                ; Gopher CSO search
  2206.        (equal type "www/gopher-cso-search")
  2207.        (string-match "search-by=" file)) ; With a search term in it
  2208.       (url-do-gopher-cso-search descr)
  2209.       (setq type "text/html"))
  2210.      ((equal type "www/gopher-cso-search") ; Blank CSO search
  2211.       (url-clear-tmp-buffer)
  2212.       (insert "<html>\n"
  2213.           " <head>\n"
  2214.           "  <title>CSO Search</title>\n"
  2215.           " </head>\n"
  2216.           " <body>\n"
  2217.           "  <div1>\n"
  2218.           "   <h1>This is a CSO search</h1>\n"
  2219.           "   <hr>\n"
  2220.           "   <form>\n"
  2221.           "    <ul>\n"
  2222.           "     <li> Search by: <select name=\"search-by\">\n"
  2223.           "                      <option>Name\n"
  2224.           "                      <option>Phone\n"
  2225.           "                      <option>Email\n"
  2226.           "                      <option>Address\n"
  2227.           "                     </select>\n"
  2228.           "     <li> Search for: <input name=\"search-term\">\n"
  2229.           "     <li> <input type=\"submit\" value=\"Submit query\">\n"
  2230.           "    </ul>\n"
  2231.           "   </form>\n"
  2232.           "  </div1>\n"
  2233.           " </body>\n"
  2234.           "</html>\n"
  2235.           "<!-- Automatically generated by URL v" url-version " -->\n")
  2236.       (setq type "text/html"
  2237.         parse-gopher t))
  2238.      ((and
  2239.        (equal type "www/gopher-search")    ; Ack!  Mosaic-style search href
  2240.        (string-match "\t" file))    ; and its got a search term in it!
  2241.       (url-gopher-retrieve host port file)
  2242.       (setq type "www/gopher"
  2243.         parse-gopher t))
  2244.      ((and
  2245.        (equal type "www/gopher-search")    ; Ack!  Mosaic-style search href
  2246.        (string-match "\\?" file))    ; and its got a search term in it!
  2247.       (setq file (concat (substring file 0 (match-beginning 0)) "\t"
  2248.              (substring file (match-end 0) nil)))
  2249.       (url-gopher-retrieve host port file)
  2250.       (setq type "www/gopher"
  2251.         parse-gopher t))
  2252.      ((equal type "www/gopher-search")    ; Ack!  Mosaic-style search href
  2253.       (setq type "text/html"
  2254.         parse-gopher t)
  2255.       (url-clear-tmp-buffer)
  2256.       (insert "<html>\n"
  2257.           " <head>\n"
  2258.           "  <title>Gopher Server</title>\n"
  2259.           " </head>\n"
  2260.           " <body>\n"
  2261.           "  <div1>\n"
  2262.           "   <h1>Searchable Gopher Index</h1>\n"
  2263.           "   <hr>\n"
  2264.           "   <p>\n"
  2265.           "    Enter the search keywords below\n"
  2266.           "   </p>"
  2267.           "   <form enctype=\"application/x-gopher-query\">\n"
  2268.           "    <input name=\"internal-gopher\">\n"
  2269.           "   </form>\n"
  2270.           "   <hr>\n"
  2271.           "  </div1>\n"
  2272.           " </body>\n"
  2273.           "</html>\n"
  2274.           "<!-- Automatically generated by URL v" url-version " -->\n"))
  2275.      ((null extr)            ; Normal Gopher link
  2276.       (url-gopher-retrieve host port file)
  2277.       (setq parse-gopher t))
  2278.      ((eq extr 'gopher+)        ; A gopher+ link
  2279.       (url-gopher-retrieve host port (concat file "\t+"))
  2280.       (setq parse-gopher t))
  2281.      ((eq extr 'ask-block)        ; A gopher+ interactive query
  2282.       (url-gopher-retrieve host port (concat file "\t!")) ; Fetch the info
  2283.       (goto-char (point-min))
  2284.       (cond
  2285.        ((re-search-forward "^\\+ASK:[ \t\r]*" nil t) ; There is an ASK
  2286.     (let ((x (buffer-substring (1+ (point))
  2287.                    (or (re-search-forward "^\\+[^:]+:" nil t)
  2288.                        (point-max)))))
  2289.       (erase-buffer)
  2290.       (insert (url-convert-ask-to-form x))
  2291.       (setq type "text/html" parse-gopher t)))
  2292.        (t (setq parse-gopher t)))))
  2293.     (if (or (equal type "www/gopher")
  2294.         (equal type "text/plain")
  2295.         (equal file "")
  2296.         (equal type "text/html"))
  2297.     (url-gopher-clean-text))
  2298.     (if (and parse-gopher (or (equal type "www/gopher")
  2299.                   (equal file "")))
  2300.     (progn
  2301.       (url-parse-gopher)
  2302.       (setq type "text/html"
  2303.         url-current-mime-viewer (mm-mime-info type nil 5))))
  2304.     (setq url-current-mime-type (or type "text/plain")
  2305.       url-current-mime-viewer (mm-mime-info type nil 5)
  2306.       url-current-file file
  2307.       url-current-port port
  2308.       url-current-server host
  2309.       url-current-type "gopher")))
  2310.  
  2311.  
  2312. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2313. ;;; WAIS support
  2314. ;;; ------------
  2315. ;;; Here are even more gross hacks that I call native WAIS support.
  2316. ;;; This code requires a working waisq program that is fully
  2317. ;;; compatible with waisq from think.com
  2318. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2319. (defun url-create-wais-source (server port dbase)
  2320.   ;; Create a temporary wais source description file.  Returns the
  2321.   ;; file name the description is in.
  2322.   (let ((x (url-generate-unique-filename))
  2323.     (y (get-buffer-create " *waisq-tmp*")))
  2324.     (save-excursion
  2325.       (set-buffer y)
  2326.       (erase-buffer)
  2327.       (insert 
  2328.        (format
  2329.     (concat "(:source\n:version 3\n"
  2330.         ":ip-name \"%s\"\n:tcp-port %s\n"
  2331.         ":database-name \"%s\"\n)")
  2332.     server (if (equal port "") "210" port) dbase))
  2333.       (write-region (point-min) (point-max) x nil nil)
  2334.       (kill-buffer y))
  2335.     x))
  2336.  
  2337. (defun url-wais-stringtoany (str)
  2338.   ;; Return a wais subelement that specifies STR in any database
  2339.   (concat "(:any :size " (length str) " :bytes #( "
  2340.       (mapconcat 'identity str " ")
  2341.       " ) )"))
  2342.  
  2343. ;(defun url-retrieve-wais-docid (server port dbase local-id)
  2344. ;  (call-process "waisretrieve" nil url-working-buffer nil
  2345. ;        (format "%s:%s@%s:%s" (url-unhex-string local-id)
  2346. ;            dbase server port)))
  2347.  
  2348. ;(url-retrieve-wais-docid "quake.think.com" "210" "directory-of-servers"
  2349. ;            "0 2608 /proj/wais/wais-sources/vpiej-l.src")
  2350. (defun url-retrieve-wais-docid (server port dbase local-id)
  2351.   ;; Retrieve a wais document.
  2352.   ;; SERVER is the server the database is on (:ip-name in source description)
  2353.   ;; PORT is the port number to contact (:tcp-port in the source description)
  2354.   ;; DBASE is the database name (:database-name in the source description)
  2355.   ;; LOCAL-ID is the document (:original-local-id in the question description)
  2356.   (let* ((dbf (url-create-wais-source server port dbase))
  2357.      (qstr (format
  2358.         (concat "(:question :version 2\n"
  2359.             "           :result-documents\n"
  2360.             "           ( (:document-id\n"
  2361.             "              :document\n"
  2362.             "              (:document\n"
  2363.             "               :headline \"\"\n"
  2364.             "               :doc-id\n"
  2365.             "               (:doc-id :original-database %s\n"
  2366.             "                :original-local-id %s )\n"
  2367.             "               :number-of-bytes -1\n"
  2368.             "               :type \"\"\n"
  2369.             "               :source\n"
  2370.             "               (:source-id :filename \"%s\") ) ) ) )")
  2371.         (url-wais-stringtoany dbase)
  2372.         (url-wais-stringtoany (url-unhex-string local-id))
  2373.         dbf))
  2374.      (qf (url-generate-unique-filename)))
  2375.     (set-buffer (get-buffer-create url-working-buffer))
  2376.     (insert qstr)
  2377.     (write-region (point-min) (point-max) qf nil nil)
  2378.     (erase-buffer)
  2379.     (call-process url-waisq-prog nil url-working-buffer nil "-f" qf "-v" "1")
  2380.     (save-excursion
  2381.       (set-buffer url-working-buffer)
  2382.       (setq url-current-file (url-unhex-string local-id)))
  2383.     (condition-case ()
  2384.     (delete-file dbf)
  2385.       (error nil))
  2386.     (condition-case ()
  2387.     (delete-file qf)
  2388.       (error nil))))
  2389.  
  2390. ;(url-perform-wais-query "quake.think.com" "210" "directory-of-servers" "SGML")
  2391. (defun url-perform-wais-query (server port dbase search)
  2392.   ;; Perform a wais query.
  2393.   ;; SERVER is the server the database is on (:ip-name in source description)
  2394.   ;; PORT is the port number to contact (:tcp-port in the source description)
  2395.   ;; DBASE is the database name (:database-name in the source description)
  2396.   ;; SEARCH is the search term (:seed-words in the question description)"
  2397.   (let ((dbfname (url-create-wais-source server port dbase))
  2398.     (qfname (url-generate-unique-filename))
  2399.     (results 'url-none-gotten))
  2400.     (save-excursion
  2401.       (url-clear-tmp-buffer)
  2402.       (insert
  2403.        (format
  2404.     (concat "(:question\n"
  2405.         " :version 2\n"
  2406.         " :seed-words \"%s\"\n"
  2407.         " :sourcepath \"" url-temporary-directory "\"\n"
  2408.         " :sources\n"
  2409.         " (  (:source-id\n"
  2410.         "     :filename \"%s\"\n"
  2411.         "    )\n"
  2412.         " )\n"
  2413.         " :maximum-results 100)\n")
  2414.     search dbfname))
  2415.       (write-region (point-min) (point-max) qfname nil nil)
  2416.       (erase-buffer)
  2417.       (call-process url-waisq-prog nil url-working-buffer nil "-g" "-f" qfname)
  2418.       (set-buffer url-working-buffer)
  2419.       (erase-buffer)
  2420.       (setq url-current-server server
  2421.         url-current-port port
  2422.         url-current-file dbase)
  2423.       (mm-insert-file-contents qfname)
  2424.       (goto-char (point-min))
  2425.       (if (re-search-forward "(:question" nil t)
  2426.       (delete-region (point-min) (match-beginning 0)))
  2427.       (url-replace-regexp "Process.*finished.*" "")
  2428.       (subst-char-in-region (point-min) (point-max) 35 32)
  2429.       (goto-char (point-min))
  2430.       (message "Done reading info - parsing results...")
  2431.       (if (re-search-forward ":result-documents[^(]+" nil t)
  2432.       (progn
  2433.         (goto-char (match-end 0))
  2434.         (while (eq results 'url-none-gotten)
  2435.           (condition-case ()
  2436.           (setq results (read (current-buffer)))
  2437.         (error (progn
  2438.              (setq results 'url-none-gotten)
  2439.              (goto-char (match-end 0))))))
  2440.         (erase-buffer)
  2441.         (insert "<title>Results of WAIS search</title>\n"
  2442.             "<h1>Searched " dbase " for " search "</h1>\n"
  2443.             "<hr>\n"
  2444.             "Found <b>" (int-to-string (length results))
  2445.             "</b> matches.\n"
  2446.             "<ol>\n<li>"
  2447.             (mapconcat 'url-parse-wais-doc-id results "\n<li>")
  2448.             "\n</ol>\n<hr>\n"))
  2449.     (message "No results"))
  2450.       (setq url-current-mime-type "text/html")
  2451.       (condition-case ()
  2452.       (delete-file qfname)
  2453.     (error nil))
  2454.       (condition-case ()
  2455.       (delete-file dbfname)
  2456.     (error nil)))))
  2457.  
  2458. (defun url-wais-anytostring (x)
  2459.   ;; Convert a (:any ....) wais construct back into a string.
  2460.   (mapconcat 'char-to-string (car (cdr (memq ':bytes x))) ""))
  2461.  
  2462. (defun url-parse-wais-doc-id (x)
  2463.   ;; Return a list item that points at the doc-id specified by X
  2464.   (let* ((document (car (cdr (memq ':document x))))
  2465.      (doc-id (car (cdr (memq ':doc-id document))))
  2466.      (score (car (cdr (memq ':score x)))) 
  2467.      (title (car (cdr (memq ':headline document))))
  2468.      (type (car (cdr (memq ':type document))))
  2469.      (size (car (cdr (memq ':number-of-bytes document))))
  2470.      (server (car (cdr (memq ':original-server doc-id))))
  2471.      (dbase (car (cdr (memq ':original-database doc-id))))
  2472.      (localid (car (cdr (memq ':original-local-id doc-id))))
  2473.      (dist-server (car (cdr (memq ':distributor-server doc-id))))
  2474.      (dist-dbase (car (cdr (memq ':distributor-database doc-id))))
  2475.      (dist-id (car (cdr (memq ':distributor-local-id doc-id))))
  2476.      (copyright (or (car (cdr (memq ':copyright-disposition doc-id))) 0)))
  2477.     (format "<a href=\"wais://%s:%s/%s/%s/%d/1=%s;2=%s;3=%s;4=%s;5=%s;6=%s;7=%d;\">%s (Score = %s)</a>"
  2478.         url-current-server url-current-port url-current-file
  2479.         type size
  2480.         (url-hexify-string (url-wais-anytostring server))
  2481.         (url-hexify-string (url-wais-anytostring dbase))
  2482.         (url-hexify-string (url-wais-anytostring localid))
  2483.         (url-hexify-string (url-wais-anytostring dist-server))
  2484.         (url-hexify-string (url-wais-anytostring dist-dbase))
  2485.         (url-hexify-string (url-wais-anytostring dist-id))
  2486.         copyright title score)))
  2487.  
  2488.  
  2489. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2490. ;;; Grokking different types of URLs
  2491. ;;; --------------------------------
  2492. ;;; Different functions for parsing out URLs, based on the type of
  2493. ;;; link (http/wais/etc).  These must be passed a fully qualified URL.
  2494. ;;; All the functions do their best to handle bad/ugly URLs, but
  2495. ;;; nothing is perfect.
  2496. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2497. (defun url-grok-wais-href (url)
  2498.   "Return a list of server, port, database, search-term, doc-id"
  2499.   (if (string-match "wais:/+\\([^/:]+\\):*\\([^/]*\\)/+\\(.*\\)" url)
  2500.       (let ((host (url-match url 1))
  2501.         (port (url-match url 2))
  2502.         (data (url-match url 3)))
  2503.     (list host port data))
  2504.     (make-list 3 nil)))
  2505.  
  2506. (defun url-grok-gopher-href (url)
  2507.   "Return a list of attributes from a gopher url.  List is of the
  2508. type: host port selector-string MIME-type extra-info"
  2509.   (let (host                ; host name
  2510.     port                ; Port #
  2511.     selector            ; String to send to gopher host
  2512.     type                ; MIME type
  2513.     extra                ; Extra information
  2514.     x                ; Temporary storage for host/port
  2515.     y                ; Temporary storage for selector
  2516.     ylen
  2517.     )
  2518.     (or (string-match "gopher:/*\\([^/]+\\)\\(/*\\)" url)
  2519.     (error "Can't understand url %s" url))
  2520.     (setq x (url-match url 1)        ; The host (and possible port #)
  2521.       ylen (- (length url) (match-end 2))
  2522.       y (if (= ylen 0)        ; The selector (and possible type)
  2523.         ""
  2524.         (url-unhex-string (substring url (- ylen)))))
  2525.  
  2526.     ;First take care of the host/port/gopher+ information from the url
  2527.     ;A + after the port # (host:70+) specifies a gopher+ link
  2528.     ;A ? after the port # (host:70?) specifies a gopher+ ask block
  2529.     (if (string-match "^\\([^:]+\\):\\([0-9]+\\)\\([?+]*\\)" x)
  2530.     (setq host (url-match x 1)
  2531.           port (url-match x 2)
  2532.           extra (url-match x 3))
  2533.       (setq host x
  2534.         port "70"
  2535.         extra nil))
  2536.     (cond
  2537.      ((equal extra "")  (setq extra nil))
  2538.      ((equal extra "?") (setq extra 'ask-block))
  2539.      ((equal extra "+") (setq extra 'gopher+)))
  2540.  
  2541.     ; Next, get the type/get rid of the Mosaic double-typing. Argh.
  2542.     (setq x (string-to-char y)        ; Get gopher type
  2543.       selector (if (or url-use-hypertext-gopher
  2544.                (< 3 (length y)))
  2545.                y        ; Get the selector string
  2546.              (substring y 1 nil))
  2547.       type (cdr (assoc x url-gopher-to-mime)))
  2548.     (list host port (or selector "") type extra)))
  2549.  
  2550.  
  2551. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2552. ;;; Parsing/updating the user's .newsrc file
  2553. ;;; ----------------------------------------
  2554. ;;; Large parts of this code are based on the newsrc parsing of the
  2555. ;;; lucid emacs version of GNUS, and is very fast and efficient.
  2556. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2557. (defun url-parse-newsrc (&optional newsrc-file)
  2558.   ;; Parse out a newsrc.  This was largely yanked out of gnus
  2559.   (save-excursion
  2560.     (setq newsrc-file (or newsrc-file (expand-file-name
  2561.                        (concat "~/.newsrc" url-news-server))))
  2562.     (if (and (file-exists-p newsrc-file)
  2563.          (file-readable-p newsrc-file))
  2564.     (message "Using newsrc file %s... " newsrc-file)
  2565.       (setq newsrc-file (expand-file-name "~/.newsrc")))
  2566.     (or (file-exists-p newsrc-file)
  2567.     (file-readable-p newsrc-file)
  2568.     (error "%s could not be read." newsrc-file))
  2569.     (set-buffer (get-buffer-create " *newsrc*"))
  2570.     (erase-buffer)
  2571.     (mm-insert-file-contents newsrc-file)
  2572.     (url-replace-regexp "^[ \t]options.*\n" "")
  2573.     (let ((subscribe nil)
  2574.       (read-list nil)
  2575.       newsgroup
  2576.       p p2)
  2577.       (save-restriction
  2578.     (while (not (eobp))
  2579.       (cond
  2580.        ((= (following-char) ?\n)
  2581.         ;; skip blank lines
  2582.         nil)
  2583.        (t
  2584.         (setq p (point))
  2585.         (skip-chars-forward "^:!\n")
  2586.         (if (= (following-char) ?\n)
  2587.         (error "unparsable line in %s" (buffer-name)))
  2588.         (setq p2 (point))
  2589.         (skip-chars-backward " \t")
  2590.         (setq newsgroup (read (buffer-substring p (point))))
  2591.         (goto-char p2)
  2592.  
  2593.         (setq subscribe (= (following-char) ?:))
  2594.         (setq read-list nil)
  2595.  
  2596.         (forward-char 1)        ; after : or !
  2597.         (skip-chars-forward " \t")
  2598.         (while (not (= (following-char) ?\n))
  2599.           (skip-chars-forward " \t")
  2600.           (or
  2601.            (and (cond
  2602.              ((looking-at "\\([0-9]+\\)-\\([0-9]+\\)") ; a range
  2603.               (setq read-list
  2604.                 (cons
  2605.                  (cons
  2606.                   (progn
  2607.                 ;; faster than buffer-substring/string-to-int
  2608.                 (narrow-to-region (point-min) (match-end 1))
  2609.                 (read (current-buffer)))
  2610.                   (progn
  2611.                 (narrow-to-region (point-min) (match-end 2))
  2612.                 (forward-char) ; skip over "-"
  2613.                 (prog1
  2614.                     (read (current-buffer))
  2615.                   (widen))))
  2616.                  read-list))
  2617.               t)
  2618.              ((looking-at "[0-9]+")
  2619.               ;; faster than buffer-substring/string-to-int
  2620.               (narrow-to-region (point-min) (match-end 0))
  2621.               (setq p (read (current-buffer)))
  2622.               (widen)
  2623.               (setq read-list (cons (cons p p) read-list))
  2624.               t)
  2625.              (t
  2626.               ;; bogus chars in ranges
  2627.               nil))
  2628.             (progn
  2629.               (goto-char (match-end 0))
  2630.               (skip-chars-forward " \t")
  2631.               (cond ((= (following-char) ?,)
  2632.                  (forward-char 1)
  2633.                  t)
  2634.                 ((= (following-char) ?\n)
  2635.                  t)
  2636.                 (t
  2637.                  ;; bogus char after range
  2638.                  nil))))
  2639.            ;; if we get here, the parse failed
  2640.            (progn
  2641.          (end-of-line)        ; give up on this line
  2642.          (ding)
  2643.          (message "Ignoring bogus line for %s in %s"
  2644.               newsgroup (buffer-name))
  2645.          (sleep-for 1)
  2646.          )))
  2647.         (put 'url-newsrc newsgroup (cons subscribe (nreverse read-list)))))
  2648.       (forward-line 1))))
  2649.     (kill-buffer (current-buffer))
  2650.     (put 'url-newsrc 'parsed t)))
  2651.  
  2652. (defun url-save-newsrc (&optional fname)
  2653.   ;; Save the newsrc of the user
  2654.   (set-buffer (get-buffer-create " *newsrc*"))
  2655.   (erase-buffer)
  2656.   (mm-insert-file-contents (or fname (expand-file-name "~/.newsrc")))
  2657.   (goto-char (point-min))
  2658.   (delete-non-matching-lines "^[ \t]options")    ; preserve option lines
  2659.   (goto-char (point-max))
  2660.   (let ((grps (symbol-plist 'url-newsrc)) grp info)
  2661.     (while grps
  2662.       (setq grp (car grps)
  2663.         info (car (cdr grps))
  2664.         grps (cdr (cdr grps)))
  2665.       (if (eq grp 'parsed)
  2666.       nil
  2667.     (insert (symbol-name grp) (if (car info) ": " "! ")
  2668.         (mapconcat
  2669.          (function
  2670.           (lambda (range)
  2671.             (cond
  2672.              ((consp range) (concat (car range) "-" (cdr range)))
  2673.              ((numberp range) range)))) (cdr info) ",") "\n")))))
  2674.              
  2675. (defun url-retrieve-newsgroup (group &optional show-all howmany)
  2676.   ;; Select newsgroup NEWSGROUP and return a list of headers of the remaining
  2677.   ;; articles
  2678.   (or (get 'url-newsrc 'parsed) (url-parse-newsrc))
  2679.   (if (symbolp group) (setq group (symbol-name group)))
  2680.   (let ((stat
  2681.      (cond
  2682.       ((string-match "flee" nntp-version)
  2683.        (nntp/command "GROUP" group)
  2684.        (save-excursion
  2685.          (set-buffer nntp-server-buffer)
  2686.          (while (progn
  2687.               (goto-char (point-min))
  2688.               (not (re-search-forward
  2689.                 "[0-9]+[ \t]+[0-9]+[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)" nil t)))
  2690.            (url-accept-process-output nntp/connection))
  2691.          (cons (string-to-int
  2692.             (buffer-substring (match-beginning 1) (match-end 1)))
  2693.            (string-to-int
  2694.             (buffer-substring (match-beginning 2) (match-end 2))))))
  2695.       (t
  2696.        (nntp-request-group group)
  2697.        (let ((msg (nntp-status-message)))
  2698.          (if (string-match "[0-9]+[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)"
  2699.                    msg)
  2700.          (cons (string-to-int (url-match msg 1))
  2701.                (string-to-int (url-match msg 2)))
  2702.            (cons 0 0))))))
  2703.     (info (cdr (get 'url-newsrc (read group))))
  2704.     (seqs '())
  2705.     (temp nil)
  2706.     (last nil)            ; last unread article
  2707.     )
  2708.     (setq last (car stat))
  2709.     (url-lazy-message "Finding unread articles...")
  2710.     (if show-all
  2711.     (setq seqs (url-make-sequence (car stat) (cdr stat)))
  2712.       (while info
  2713.     (setq temp (car info)
  2714.           info (cdr info))
  2715.     (cond
  2716.      ((consp temp)            ; a range of articles
  2717.       (setq seqs (nconc seqs (url-make-sequence last (1- (car temp))))
  2718.         last (1+ (cdr temp))))
  2719.      ((numberp temp)
  2720.       (setq seqs (nconc seqs (url-make-sequence last (1- temp)))
  2721.         last (1+ temp))))))
  2722.     (setq seqs (nconc seqs (url-make-sequence last (cdr stat))))
  2723.     (and seqs (nntp-retrieve-headers seqs))))
  2724.  
  2725. (defun url-get-new-newsgroups (&optional tm)
  2726.   ;; Get a string suitable for an NTTP server to get a list of new newsgroups.
  2727.   ;; Optional argument TM is a list of three integers. The first has the
  2728.   ;; most significant 16 bits of the seconds, while the second has the
  2729.   ;; least significant 16 bits.  The third integer gives the microsecond
  2730.   ;; count.  (The format returned either by (current-time) or file-attributes
  2731.   ;; mod-time, etc.)
  2732.   (let* ((x (if url-current-time-string-has-args
  2733.         (current-time-string tm)
  2734.           (current-time-string)))
  2735.      (y (cdr (assoc (substring x 4 7) monthabbrev-alist)))
  2736.      (z (substring x 9 10)))
  2737.     (concat "NEWGROUPS "
  2738.         (substring x -2 nil)
  2739.         (if (< y 10) "0" "")
  2740.         y
  2741.         (if (= (length z) 2) "" "0")
  2742.         z " "
  2743.         (substring x 11 13)
  2744.         (substring x 14 16)
  2745.         (substring x 17 19))))
  2746.       
  2747. (defun url-format-news ()
  2748.   (url-clear-tmp-buffer)
  2749.   (insert "HTTP/1.0 200 Retrieval OK\r\n"
  2750.       (save-excursion
  2751.         (set-buffer nntp-server-buffer)
  2752.         (buffer-string)))
  2753.   (url-parse-mime-headers)
  2754.   (let ((from  (cdr (assoc "from" url-current-mime-headers)))
  2755.     (subj  (cdr (assoc "subject" url-current-mime-headers)))
  2756.     (org   (cdr (assoc "organization" url-current-mime-headers)))
  2757.     (typ   (or (cdr (assoc "content-type" url-current-mime-headers))
  2758.            "text/plain"))
  2759.     (grps  (mapcar 'car
  2760.                (url-split
  2761.             (or (cdr (assoc "newsgroups" url-current-mime-headers))
  2762.                 "")
  2763.             "[ \t\n,]+")))
  2764.     (refs  (mapcar 'car
  2765.                (url-split
  2766.             (or (cdr (assoc "references" url-current-mime-headers))
  2767.                 "")
  2768.             "[ \t,\n<>]+")))
  2769.     (date  (cdr (assoc "date" url-current-mime-headers))))
  2770.     (setq url-current-file ""
  2771.       url-current-type "")
  2772.     (if (or (not (string-match "text/" typ))
  2773.         (string-match "text/html" typ))
  2774.     nil                ; Let natural content-type take over
  2775.       (insert "<html>\n"
  2776.           " <head>\n"
  2777.           "  <title>" subj "</title>\n"
  2778.           "  <link rev=\"made\" href=\"mailto:" from "\">\n"
  2779.           " </head>\n"
  2780.           " <body>\n"
  2781.           "  <div1>\n"
  2782.           "   <h1 align=center>" subj "</h1>\n"
  2783.           "   <p role=\"headers\">\n"
  2784.           "    <b>From</b>: <address> " from "</address><br>\n"
  2785.           "    <b>Newsgroups</b>: "
  2786.           (mapconcat
  2787.            (function
  2788.         (lambda (grp)
  2789.           (concat "<a href=\"" grp "\"> " grp "</a>"))) grps ", ")
  2790.           "<br>\n"
  2791.           (if org
  2792.           (concat
  2793.            "    <b>Organization</b>: <i> " org "</i> <br>\n")
  2794.         "")
  2795.           "    <b>Date</b>: <date> " date "</date> <br>\n"
  2796.           "   </p> <hr>\n"
  2797.           (if (null refs)
  2798.           ""
  2799.         (concat
  2800.          "   <p align=\"center\">References\n"
  2801.          "    <ol>\n"
  2802.          (mapconcat
  2803.           (function
  2804.            (lambda (ref)
  2805.              (concat "     <li> <a href=\"" ref "\"> " 
  2806.                  ref "</a></li>\n")))
  2807.           refs "")
  2808.          "    </ol>\n"
  2809.          "   <hr>\n"))
  2810.           "   <ul plain>\n"
  2811.           "    <li><a href=\"newspost:disfunctional\"> "
  2812.           "Post to this group </a></li>\n"
  2813.           "    <li><a href=\"mailto:" from "\"> Reply to " from
  2814.           "</a></li>\n"
  2815.           "   </ul>\n"
  2816.           "   <hr>"
  2817.           "   <xmp>\n")
  2818.       (goto-char (point-max))
  2819.       (setq url-current-mime-type "text/html"
  2820.         url-current-mime-viewer (mm-mime-info url-current-mime-type nil 5))
  2821.       (let ((x (assoc "content-type" url-current-mime-headers)))
  2822.     (if x
  2823.         (setcdr x "text/html")
  2824.       (setq url-current-mime-headers (cons (cons "content-type"
  2825.                              "text/html")
  2826.                            url-current-mime-headers))))
  2827.       (insert "\n"
  2828.           "   </xmp>\n"
  2829.           "  </div1>\n"
  2830.           " </body>\n"
  2831.           "</html>\n"
  2832.           "<!-- Automatically generated by URL/" url-version
  2833.           "-->"))))
  2834.  
  2835. (defun url-format-whole-newsgroup (newsgroup header-list)
  2836.   (url-clear-tmp-buffer)
  2837.   (insert "<html>\n"
  2838.       " <head>\n"
  2839.       "  <title>" newsgroup "</title>\n"
  2840.       " </head>\n"
  2841.       " <body>\n"
  2842.       "  <div1>\n"
  2843.       "   <h1 align=center>" newsgroup "</h1>\n"
  2844.       "   <hr>\n"
  2845.       "   <p>\n"
  2846.       "   <ol>\n"
  2847.       (mapconcat
  2848.        (function
  2849.         (lambda (artcl)
  2850.           (let ((id (nntp-header-id artcl))
  2851.             (subj (nntp-header-subject artcl))
  2852.             (from (nntp-header-from artcl)))
  2853.         (if (string-match "<\\(.*\\)>" id)
  2854.             (setq id (url-match id 1)))
  2855.         (concat "    <li> <a href=\"" id "\"> " subj "</a> <br>\n"
  2856.             "         " from " </li>\n")))) header-list "")
  2857.       "   </ol>\n"
  2858.       "  </div1>\n"
  2859.       " </body>\n"
  2860.       "</html>\n"
  2861.       "<!-- Automatically generated by URL/" url-version
  2862.       "-->"))
  2863.  
  2864. (defun url-show-all-newsgroups ()
  2865.   (or (get 'url-newsrc 'parsed) (url-parse-newsrc))
  2866.   (let ((grps (symbol-plist 'url-newsrc))
  2867.     grp info)
  2868.     (insert "<html>\n"
  2869.         " <head>\n"
  2870.         "  <title> Newsgroups </title>\n"
  2871.         " </head>\n"
  2872.         " <body>\n"
  2873.         "  <div1>\n"
  2874.         "   <h1> Newsgroup listing </h1>\n"
  2875.         "   <pre>\n")
  2876.     (while grps
  2877.       (setq grp (symbol-name (car grps))
  2878.         info (car (cdr grps))
  2879.         grps (cdr (cdr grps)))
  2880.       (if (eq grp 'parsed)
  2881.       nil
  2882.     (insert (format "    <a href=\"%s\">%7d%s %s" grp
  2883.             (url-retrieve-newsgroup grp nil t)
  2884.             (if (car info) ": " "! ") grp))))
  2885.     (insert "   </pre>\n"
  2886.         "  </div1>\n"
  2887.         " </body>\n"
  2888.         "</html>\n"
  2889.         "<!-- Automatically generated by URL/" url-version
  2890.         "-->")))    
  2891.  
  2892. (defun url-news-generate-reply-form (to newsgroups body &rest refs)
  2893.   (set-buffer (get-buffer-create url-working-buffer))
  2894.   (erase-buffer)
  2895.   (insert "<html>\n"
  2896.       " <head>\n"
  2897.       "  <title>News Post/Reply Form</title>\n"
  2898.       "  <!-- Automatically generated by URL -->\n"
  2899.       " </head>\n"
  2900.       " <body>\n"
  2901.       "  <div1>\n"
  2902.       "   <h1>News Post/Reply Form</h1>\n"
  2903.       "   <hr>\n"
  2904.       "   <form method=\"GET\" action=\"news-internal://\">\n"
  2905.       "    <ul>\n"
  2906.       "     <li> Reply by:"
  2907.       "<select name=\"replyby\"><option>Mail<option>News</select></li>\n"
  2908.       "     <li> Email: <input name=\"addr\" default=\"" to "\"></li>\n"
  2909.       "     <li> Newsgroups: <input name=\"newsg\" default=\""
  2910.       newsgroups "\"></li>\n"
  2911.       "     <li> <input type=\"checkbox\" name=\"include\">"
  2912.       "Include/quote article in followup</li>\n"
  2913.       "    </ul>\n"
  2914.       "    <hr>\n"
  2915.       "    <textarea \"name=body\">\n" body "\n</textarea>\n"
  2916.       "    <hr>\n"
  2917.       "    <input type=\"submit\" value=\"Send it\">\n"
  2918.       "    <br>\n"
  2919.       "    <input type=\"reset\"  value=\"Reset to default values\">\n"
  2920.       "   </form>\n"
  2921.       "  </div1>\n"
  2922.       " </body>\n"
  2923.       "</html>\n"))        
  2924.  
  2925. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2926. ;;; Support for the different types of urls
  2927. ;;; ---------------------------------------
  2928. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2929. (defun url-wais (url)
  2930.   ;; Retrieve a document via WAIS
  2931.   (if (and url-wais-gateway-server url-wais-gateway-port)
  2932.       (url-retrieve
  2933.        (format "http://%s:%s/%s"
  2934.            url-wais-gateway-server
  2935.            url-wais-gateway-port
  2936.            (substring url (match-end 0) nil)))
  2937.     (let ((href (url-grok-wais-href url)))
  2938.       (url-clear-tmp-buffer)
  2939.       (setq url-current-type "wais"
  2940.         url-current-server (nth 0 href)
  2941.         url-current-port (nth 1 href)
  2942.         url-current-file (nth 2 href))
  2943.       (cond
  2944.        ((string-match "2=\\(.*\\);3=\\([^ ;]+\\)" (nth 2 href)); full link
  2945.     (url-retrieve-wais-docid (nth 0 href) (nth 1 href)
  2946.                 (url-match (nth 2 href) 1)
  2947.                 (url-match (nth 2 href) 2)))
  2948.        ((string-match "\\([^\\?]+\\)\\?\\(.*\\)" (nth 2 href)) ; stored query
  2949.     (url-perform-wais-query (nth 0 href) (nth 1 href)
  2950.                    (url-match (nth 2 href) 1)
  2951.                    (url-match (nth 2 href) 2)))
  2952.        (t
  2953.     (insert "<title>WAIS search</title>\n"
  2954.         "<h1>WAIS search of " (nth 2 href) "</h1>"
  2955.         "<hr>\n"
  2956.         "<form>\n"
  2957.         "Enter search term: <input name=\"internal-wais\">\n"
  2958.         "</form>\n"
  2959.         "<hr>\n"))))))
  2960.  
  2961. (autoload 'Info-goto-node "info" "" t)
  2962.  
  2963. (defun url-info (url)
  2964.   ;; Fetch an info node
  2965.   (let* ((data (url-generic-parse-url url))
  2966.      (fname (url-filename data))
  2967.      (node (or (url-target data) "Top")))
  2968.     (if (and fname node)
  2969.     (Info-goto-node (concat "(" fname ")" node))
  2970.       (error "Malformed url: %s" url))))
  2971.  
  2972. (defun url-https (url)
  2973.   ;; Retrieve a URL via SSL
  2974.   (condition-case ()
  2975.       (require 'ssl)
  2976.     (error (error "Not configured for SSL, please read the info pages.")))
  2977.   (let ((url-this-is-ssl t)
  2978.     (url-gateway-method 'ssl))
  2979.     (url-http url)))
  2980.  
  2981. (defun url-shttp (url)
  2982.   ;; Retrieve a URL via Secure-HTTP
  2983.   (error "Secure-HTTP not implemented yet."))
  2984.  
  2985. (defun url-http (url &optional proxy-info)
  2986.   ;; Retrieve URL via http.
  2987.   (let* ((urlobj (url-generic-parse-url url))
  2988.      (ref-url (or url-current-referer (url-view-url t))))
  2989.     (url-clear-tmp-buffer)
  2990.     (setq url-current-type (if (boundp 'url-this-is-ssl)
  2991.                    "https" "http"))
  2992.     (let* ((server (url-host urlobj))
  2993.        (port   (url-port urlobj))
  2994.        (file   (or proxy-info (url-filename urlobj)))
  2995.        (dest   (url-target urlobj))
  2996.        request)
  2997.       (if (equal port "") (setq port "80"))
  2998.       (if (equal file "") (setq file "/"))
  2999.       (if proxy-info
  3000.       (let ((x (url-generic-parse-url url)))
  3001.         (setq url-current-server (url-host urlobj)
  3002.           url-current-port (url-port urlobj)
  3003.           url-current-file (url-filename urlobj)
  3004.           url-find-this-link (url-target urlobj)
  3005.           request (url-create-mime-request file ref-url)))
  3006.     (setq url-current-server server
  3007.           url-current-port port
  3008.           url-current-file file
  3009.           url-find-this-link dest
  3010.           request (url-create-mime-request file ref-url)))
  3011.       (if (or (not (member port url-bad-port-list))
  3012.           (funcall url-confirmation-func
  3013.                (concat
  3014.             "Warning!  Trying to connect to port "
  3015.             port
  3016.             " - continue? ")))
  3017.       (progn
  3018. ;        (url-lazy-message "Fetching: %s %s %s" server port file)
  3019.         (url-lazy-message "Contacting %s:%s" server port)
  3020.         (let ((process
  3021.            (url-open-stream "WWW" url-working-buffer server
  3022.                    (string-to-int port))))
  3023.           (if (stringp process)
  3024.           (progn
  3025.             (set-buffer url-working-buffer)
  3026.             (erase-buffer)
  3027.             (setq url-current-mime-type "text/html"
  3028.               url-current-mime-viewer 
  3029.               (mm-mime-info "text/html" nil 5))
  3030.             (insert "<title>ERROR</title>\n"
  3031.                 "<h1>ERROR - Could not establish connection</h1>"
  3032.                 "<p>"
  3033.                 "The browser could not establish a connection "
  3034.                 (format "to %s:%s.<P>" server port)
  3035.                 "The server is either down, or the URL"
  3036.                 (format "(%s) is malformed.<p>" (url-view-url t)))
  3037.             (message "%s" process))
  3038.         (progn
  3039.           (process-kill-without-query process)
  3040.           (process-send-string process request)
  3041.           (url-lazy-message "Request sent, waiting for response...")
  3042.           (if (and url-show-http2-transfer
  3043.                (boundp 'after-change-functions))
  3044.               (progn
  3045.             (make-local-variable 'after-change-functions)
  3046.             (add-hook 'after-change-functions
  3047.                   'url-after-change-function)))
  3048.           (if url-be-asynchronous
  3049.               (set-process-sentinel process 'url-sentinel)
  3050.             (unwind-protect
  3051.             (save-excursion
  3052.               (set-buffer url-working-buffer)
  3053.               (while (memq (url-process-status process)
  3054.                        '(run open))
  3055.                 (if (boundp 'after-change-functions)
  3056.                 nil
  3057.                   (url-after-change-function nil))
  3058.                 (url-accept-process-output process)))
  3059.               (condition-case ()
  3060.               (url-kill-process process)
  3061.             (error nil))))
  3062.             (message "Retrieval complete.")
  3063.             (if (boundp 'after-change-functions)
  3064.             (remove-hook 'after-change-functions
  3065.                      'url-after-change-function))))))
  3066.     (progn
  3067.       (ding)
  3068.       (url-warn 'security "Aborting connection to bad port..."))))))
  3069.  
  3070. (defun url-proxy (url)
  3071.   ;; Retrieve URL from a proxy.
  3072.   ;; Expects `url-using-proxy' to be bound to the specific proxy to use."
  3073.   (let ((url-be-asynchronous nil)
  3074.     (urlobj (url-generic-parse-url url))
  3075.     (proxyobj (url-generic-parse-url url-using-proxy)))
  3076.     (url-http url-using-proxy url)
  3077.     (setq url-current-type (url-type urlobj)
  3078.       url-current-user (url-user urlobj)
  3079.       url-current-port (or (url-port urlobj)
  3080.                    (cdr-safe (assoc url-current-type
  3081.                         url-default-ports)))
  3082.       url-current-server (url-host urlobj)
  3083.       url-current-file (url-filename urlobj))))
  3084.  
  3085. (defun url-insert-possibly-compressed-file (fname &rest args)
  3086.   ;; Insert a file into a buffer, checking for compressed versions.
  3087.   (let ((compressed nil)
  3088.     (file-coding-system-for-read
  3089.       (if (boundp 'MULE)
  3090.           *noconv*)))
  3091.     (setq compressed 
  3092.       (cond
  3093.        ((file-exists-p fname) nil)
  3094.        ((file-exists-p (concat fname ".Z"))
  3095.         (setq fname (concat fname ".Z")))
  3096.        ((file-exists-p (concat fname ".gz"))
  3097.         (setq fname (concat fname ".gz")))
  3098.        ((file-exists-p (concat fname ".z"))
  3099.         (setq fname (concat fname ".z")))
  3100.        (t
  3101.         (error "File not found %s" fname))))
  3102.     (if (or (not compressed) url-inhibit-uncompression)
  3103.     (apply 'mm-insert-file-contents (cons fname args))
  3104.       (let* ((extn (url-file-extension fname))
  3105.          (code (cdr-safe (assoc extn url-uncompressor-alist)))
  3106.          (decoder (cdr-safe (assoc code mm-content-transfer-encodings))))
  3107.     (cond
  3108.      ((null decoder) 
  3109.       (apply 'mm-insert-file-contents fname args))
  3110.      ((stringp decoder)
  3111.       (apply 'mm-insert-file-contents fname args)
  3112.       (message "Decoding...")
  3113.       (call-process-region (point-min) (point-max) decoder t t nil)
  3114.       (message "Decoding... done."))
  3115.      ((listp decoder)
  3116.       (apply 'call-process-region (point-min) (point-max)
  3117.          (car decoder) t t t (cdr decoder)))
  3118.      ((and (symbolp decoder) (fboundp decoder))
  3119.       (apply 'mm-insert-file-contents fname args)
  3120.       (message "Decoding...")
  3121.       (funcall decoder (point-min) (point-max))
  3122.       (message "Decoding... done."))
  3123.      (t
  3124.       (error "Malformed entry for %s in `mm-content-transfer-encodings'"
  3125.          code))))))
  3126.   (set-buffer-modified-p nil))
  3127.  
  3128. (defun url-file (url)
  3129.   ;; Find a file
  3130.   (let* ((urlobj (url-generic-parse-url url))
  3131.      (user (url-user urlobj))
  3132.      (site (url-host urlobj))
  3133.      (file (url-unhex-string (url-filename urlobj)))
  3134.      (dest (url-target urlobj))
  3135.      (filename (if (or user (and site (not (string= site "localhost"))))
  3136.                (concat "/" (or user "anonymous") "@" site ":" file)
  3137.              file))
  3138.      ;; Patch by Yamaoka to not screw up jam-zcat/jka-compr by
  3139.      ;; uncompressing before they get a chance
  3140.      jka-compr-compression-info-list
  3141.      jam-zcat-filename-list)
  3142.  
  3143.     (if (and file (not site)
  3144.          (memq system-type '(ms-windows ms-dos windows-nt os2)))
  3145.     (let ((x (1- (length file)))
  3146.           (y 0))
  3147.       (while (<= y x)
  3148.         (if (= (aref file y) ?\\ )
  3149.         (aset file y ?/))
  3150.         (setq y (1+ y)))))
  3151.  
  3152.     (url-clear-tmp-buffer)
  3153.     (cond
  3154.      ((file-directory-p filename)
  3155.       (if url-use-hypertext-dired
  3156.       (progn
  3157.         (if (string-match "/$" filename)
  3158.         nil
  3159.           (setq filename (concat filename "/")))
  3160.         (if (string-match "/$" filename)
  3161.         nil
  3162.           (setq file (concat file "/")))
  3163.         (url-set-filename urlobj file)
  3164.         (url-format-directory filename))
  3165.     (progn
  3166.       (if (get-buffer url-working-buffer)
  3167.           (kill-buffer url-working-buffer))
  3168.       (find-file filename))))
  3169.      ((and (boundp 'w3-dump-to-disk) (symbol-value 'w3-dump-to-disk))
  3170.       (cond
  3171.        ((file-exists-p filename) nil)
  3172.        ((file-exists-p (concat filename ".Z"))
  3173.     (setq filename (concat filename ".Z")))
  3174.        ((file-exists-p (concat filename ".gz"))
  3175.     (setq filename (concat filename ".gz")))
  3176.        ((file-exists-p (concat filename ".z"))
  3177.     (setq filename (concat filename ".z")))
  3178.        (t
  3179.     (error "File not found %s" filename)))
  3180.       (cond
  3181.        ((null site)
  3182.     (copy-file
  3183.      filename 
  3184.      (read-file-name "Save to: " nil (url-basepath filename t)) t))
  3185.        ((featurep 'ange-ftp)
  3186.     (ange-ftp-copy-file-internal
  3187.      filename
  3188.      (expand-file-name
  3189.       (read-file-name "Save to: " nil (url-basepath filename t))) t
  3190.      nil t nil t))
  3191.        ((or (featurep 'efs) (featurep 'efs-auto))
  3192.     (let ((new (expand-file-name
  3193.             (read-file-name "Save to: " nil
  3194.                     (url-basepath filename t)))))
  3195.       (efs-copy-file-internal filename (efs-ftp-path filename)
  3196.                   new (efs-ftp-path new)
  3197.                   t nil 0 nil 0 nil)))
  3198.        (t (copy-file
  3199.        filename 
  3200.        (read-file-name "Save to: " nil (url-basepath filename t)) t)))
  3201.       (if (get-buffer url-working-buffer)
  3202.       (kill-buffer url-working-buffer)))
  3203.      (t
  3204.       (let ((viewer (mm-mime-info
  3205.              (mm-extension-to-mime (url-file-extension file))))
  3206.         (errobj nil))
  3207.     (if (or url-source        ; Need it in a buffer
  3208.         (and (symbolp viewer)
  3209.              (not (eq viewer 'w3-default-local-file)))
  3210.         (stringp viewer))
  3211.         (condition-case errobj
  3212.         (url-insert-possibly-compressed-file filename t)
  3213.           (error
  3214.            (url-save-error errobj)
  3215.            (url-retrieve (concat "www://error/nofile/" file))))))))
  3216.     (setq url-current-type (if site "ftp" "file")
  3217.       url-current-object urlobj
  3218.       url-find-this-link dest
  3219.       url-current-user user
  3220.       url-current-server site
  3221.       url-current-mime-type (mm-extension-to-mime
  3222.                  (url-file-extension file))
  3223.       url-current-file file)))
  3224.  
  3225. (defun url-finger (url)
  3226.   ;; Find a finger reference
  3227.   (setq url-current-mime-headers '(("content-type" . "text/html"))
  3228.     url-current-mime-type "text/html")
  3229.   (set-buffer (get-buffer-create url-working-buffer))
  3230.   (let* ((urlobj (if (vectorp url) url
  3231.            (url-generic-parse-url url)))
  3232.      (host (or (url-host urlobj) "localhost"))
  3233.      (port (or (url-port urlobj)
  3234.            (cdr-safe (assoc "finger" url-default-ports))))
  3235.      (user (url-unhex-string (url-filename urlobj)))
  3236.      (proc (url-open-stream "finger" url-working-buffer host
  3237.                 (string-to-int port))))
  3238.     (if (stringp proc)
  3239.     (message "%s" proc)
  3240.       (process-kill-without-query proc)
  3241.       (if (= (string-to-char user) ?/)
  3242.       (setq user (substring user 1 nil)))
  3243.       (goto-char (point-min))
  3244.       (insert "<html>\n"
  3245.           " <head>\n"
  3246.           "  <title>Finger information for " user "@" host "</title>\n"
  3247.           " </head>\n"
  3248.           " <body>\n"
  3249.           "  <h1>Finger information for " user "@" host "</h1>\n"
  3250.           "  <hr>\n"
  3251.           "  <pre>\n")
  3252.       (process-send-string proc (concat user "\r\n"))
  3253.       (while (memq (url-process-status proc) '(run open))
  3254.     (url-after-change-function)
  3255.     (url-accept-process-output proc))
  3256.       (goto-char (point-min))
  3257.       (url-replace-regexp "^Process .* exited .*code .*$" "")
  3258.       (goto-char (point-max))
  3259.       (insert "  </pre>\n"
  3260.           " </body>\n"
  3261.           "</html>\n"))))
  3262.  
  3263. (defun url-news (article)
  3264.   ;; Find a news reference
  3265.   (or noninteractive (require 'nntp))
  3266.   (setq url-current-mime-headers '(("content-type" . "text/html"))
  3267.     url-current-mime-type "text/html")
  3268.   (let* ((urlobj (url-generic-parse-url article))
  3269.      (host (or (url-host urlobj) url-news-server))
  3270.      (port (or (url-port urlobj)
  3271.            (cdr-safe (assoc "news" url-default-ports))))
  3272.      (article-brackets nil)
  3273.      (article (url-filename urlobj)))
  3274.     (or (nntp-server-opened)
  3275.     (nntp-open-server host (if (string-match (regexp-quote "4.0")
  3276.                          nntp-version)
  3277.                    (list (string-to-int port))
  3278.                  (string-to-int port))))
  3279.     (cond
  3280.      ((string-match "@" article)    ; Its a specific article
  3281.       ;; put the message-id in article, and <message-id> in article-brackets
  3282.       (cond 
  3283.        ((eq ?> (aref article (1- (length article))))
  3284.     (setq article-brackets article)
  3285.     (setq article (substring article 1 -1)))
  3286.        (t
  3287.     (setq article-brackets (concat "<" article ">"))))
  3288.       (if (boundp 'after-change-functions)
  3289.       (progn
  3290.         (set-buffer nntp-server-buffer)
  3291.         (make-local-variable 'after-change-functions)
  3292.         (add-hook 'after-change-functions 'nntp-after-change-function)))
  3293.       (if (nntp-request-article article-brackets)
  3294.       (progn
  3295.         (if (boundp 'after-change-functions)
  3296.         (progn
  3297.           (set-buffer nntp-server-buffer)
  3298.           (remove-hook 'after-change-functions
  3299.                    'nntp-after-change-function)))
  3300.         (url-format-news))
  3301.       (set-buffer (get-buffer-create url-working-buffer))
  3302.       (setq url-current-can-be-cached nil)
  3303.       (insert "<html>\n"
  3304.           " <head>\n"
  3305.           "  <title>Error</title>\n"
  3306.           " </head>\n"
  3307.           " <body>\n"
  3308.           "  <div1>\n"
  3309.           "   <h1>Error requesting article...</h1>\n"
  3310.           "   <p>\n"
  3311.           "    The status message returned by the NNTP server was:"
  3312.           "<br><hr>\n"
  3313.           "    <pre>\n"
  3314.           (nntp-status-message)
  3315.           "    </pre>\n"
  3316.           "   </p>\n"
  3317.           "   <p>\n"
  3318.           "    If you If you feel this is an error, <a href=\""
  3319.           "mailto:" url-bug-address "\">send me mail</a>\n"
  3320.           "   </p>\n"
  3321.           "  </div1>\n"
  3322.           " </body>\n"
  3323.           "</html>\n"
  3324.           "<!-- Automatically generated by URL v" url-version " -->\n"
  3325.           )))
  3326.      ((string= article "")        ; List all newsgroups
  3327.       (url-show-all-newsgroups))
  3328.      (t                    ; Whole newsgroup
  3329.       (url-format-whole-newsgroup article (url-retrieve-newsgroup article))))
  3330.     (cond
  3331.      ((boundp 'nntp-server-process)    ; original nntp.el by umeda
  3332.       (process-kill-without-query nntp-server-process))
  3333.      ((boundp 'nntp/connection)        ; Flee's version of nntp.el
  3334.       (process-kill-without-query nntp/connection))
  3335.      (t nil))                ; Unknown version of nntp.el
  3336.     (setq url-current-type "news"
  3337.       url-current-server host
  3338.       url-current-port port
  3339.       url-current-file article)))
  3340.  
  3341. (defun url-rlogin (url)
  3342.   ;; Open up an rlogin connection
  3343.   (or (string-match "rlogin:/*\\(.*@\\)*\\([^/]*\\)/*" url)
  3344.       (error "Malformed RLOGIN URL."))
  3345.   (let* ((server (substring url (match-beginning 2) (match-end 2)))
  3346.      (name (if (match-beginning 1)
  3347.            (substring url (match-beginning 1) (1- (match-end 1)))
  3348.          nil))
  3349.      (title (format "%s%s" (if name (concat name "@") "") server))
  3350.      (thebuf (string-match ":" server))
  3351.      (port (if thebuf
  3352.            (prog1
  3353.                (substring server (1+ thebuf) nil)
  3354.              (setq server (substring server 0 thebuf))) "23")))
  3355.     (cond
  3356.      ((not (eq (device-type) 'tty))
  3357.       (apply 'start-process
  3358.          "htmlsub"
  3359.          nil
  3360.          (url-string-to-tokens
  3361.           (format url-xterm-command title 
  3362.               (if (and url-gateway-local-host-regexp
  3363.                    (string-match url-gateway-local-host-regexp
  3364.                          server))
  3365.               url-local-rlogin-prog
  3366.             url-remote-rlogin-prog) server
  3367.             (concat "-l " name)) ? )))
  3368.      (url-use-transparent
  3369.       (require 'transparent)
  3370.       (sit-for 1)
  3371.       (transparent-window (get-buffer-create
  3372.                (format "%s%s:%s" (if name (concat name "@") "")
  3373.                    server port))
  3374.               (if (and url-gateway-local-host-regexp
  3375.                    (string-match url-gateway-local-host-regexp
  3376.                          server))
  3377.                   url-local-rlogin-prog
  3378.                 url-remote-rlogin-prog)
  3379.               (list server "-l" name) nil
  3380.               "Press any key to return to emacs"))
  3381.      (t
  3382.       (terminal-emulator
  3383.        (get-buffer-create (format "%s%s:%s" (if name (concat name "@") "")
  3384.                   server port))
  3385.        (if (and url-gateway-local-host-regexp
  3386.         (string-match url-gateway-local-host-regexp
  3387.                   server))
  3388.        url-local-rlogin-prog
  3389.      url-remote-rlogin-prog)
  3390.        (list server "-l" name))))))
  3391.  
  3392. (defun url-telnet (url)
  3393.   ;; Open up a telnet connection
  3394.   (or (string-match "telnet:/*\\(.*@\\)*\\([^/]*\\)/*" url)
  3395.       (error "Malformed telnet URL: %s" url))
  3396.   (let* ((server (substring url (match-beginning 2) (match-end 2)))
  3397.      (name (if (match-beginning 1)
  3398.            (substring url (match-beginning 1) (1- (match-end 1)))
  3399.          nil))
  3400.      (title (format "%s%s" (if name (concat name "@") "") server))
  3401.      (thebuf (string-match ":" server))
  3402.      (port (if thebuf
  3403.            (prog1
  3404.                (substring server (1+ thebuf) nil)
  3405.              (setq server (substring server 0 thebuf))) "23")))
  3406.     (cond
  3407.      ((not (eq (device-type) 'tty))
  3408.       (apply 'start-process
  3409.          "htmlsub"
  3410.          nil
  3411.          (url-string-to-tokens
  3412.           (format url-xterm-command title 
  3413.               (if (and url-gateway-local-host-regexp
  3414.                    (string-match url-gateway-local-host-regexp
  3415.                          server))
  3416.               url-local-telnet-prog
  3417.             url-remote-telnet-prog) server port) ? ))
  3418.       (if name (message "Please log in as %s" name)))
  3419.      (url-use-transparent
  3420.       (require 'transparent)
  3421.       (if name (message "Please log in as %s" name))
  3422.       (sit-for 1)
  3423.       (transparent-window (get-buffer-create
  3424.                (format "%s%s:%s" (if name (concat name "@") "")
  3425.                    server port))
  3426.               (if (and url-gateway-local-host-regexp
  3427.                    (string-match url-gateway-local-host-regexp
  3428.                          server))
  3429.                   url-local-telnet-prog
  3430.                 url-remote-telnet-prog)
  3431.               (list server port) nil
  3432.               "Press any key to return to emacs"))
  3433.      (t
  3434.       (terminal-emulator
  3435.        (get-buffer-create (format "%s%s:%s" (if name (concat name "@") "")
  3436.                   server port))
  3437.        (if (and url-gateway-local-host-regexp
  3438.         (string-match url-gateway-local-host-regexp
  3439.                   server))
  3440.        url-local-telnet-prog
  3441.      url-remote-telnet-prog)
  3442.        (list server port))
  3443.       (if name (message "Please log in as %s" name))))))
  3444.  
  3445. (defun url-tn3270 (url)
  3446.   ;; Open up a tn3270 connection
  3447.   (string-match "tn3270:/*\\(.*@\\)*\\([^/]*\\)/*" url)
  3448.   (let* ((server (substring url (match-beginning 2) (match-end 2)))
  3449.      (name (if (match-beginning 1)
  3450.            (substring url (match-beginning 1) (1- (match-end 1)))
  3451.          nil))
  3452.      (thebuf (string-match ":" server))
  3453.      (title (format "%s%s" (if name (concat name "@") "") server))
  3454.      (port (if thebuf
  3455.            (prog1
  3456.                (substring server (1+ thebuf) nil)
  3457.              (setq server (substring server 0 thebuf))) "23")))
  3458.     (cond
  3459.      ((not (eq (device-type) 'tty))
  3460.       (start-process "htmlsub" nil url-xterm-command
  3461.              "-title" title
  3462.              "-ut" "-e" url-tn3270-emulator server port)
  3463.       (if name (message "Please log in as %s" name)))
  3464.      (url-use-transparent
  3465.       (require 'transparent)
  3466.       (if name (message "Please log in as %s" name))
  3467.       (sit-for 1)
  3468.       (transparent-window (get-buffer-create
  3469.                (format "%s%s:%s" (if name (concat name "@") "")
  3470.                    server port))
  3471.               url-tn3270-emulator
  3472.               (list server port) nil
  3473.               "Press any key to return to emacs"))
  3474.      (t
  3475.       (terminal-emulator
  3476.        (get-buffer-create (format "%s%s:%s" (if name (concat name "@") "")
  3477.                   server port))
  3478.        url-tn3270-emulator
  3479.        (list server port))
  3480.       (if name (message "Please log in as %s" name))))))
  3481.  
  3482. (defun url-mailto (url)
  3483.   ;; Send mail to someone
  3484.   (string-match "mailto:/*\\(.*\\)" url)
  3485.   (let ((to (substring url (match-beginning 1) (match-end 1)))
  3486.     (url (url-view-url t)))
  3487.     (if (fboundp url-mail-command) (funcall url-mail-command) (mail))
  3488.     (mail-to)
  3489.     (insert (concat to "\nX-URL-From: " url))
  3490.     (mail-subject)
  3491.     (if (not url-request-data)
  3492.     nil                ; Not automatic posting
  3493.       (insert "Automatic submission from "
  3494.           url-package-name "/" url-package-version)
  3495.       (if url-request-extra-headers
  3496.       (progn
  3497.         (goto-char (point-min))
  3498.         (insert
  3499.          (mapconcat
  3500.           (function
  3501.            (lambda (x)
  3502.          (concat (capitalize (car x)) ": " (cdr x) "\n")))
  3503.           url-request-extra-headers ""))))
  3504.       (goto-char (point-max))
  3505.       (insert url-request-data)
  3506.       (mail-send-and-exit nil))))
  3507.  
  3508. (defvar url-mailserver-syntax-table
  3509.   (copy-syntax-table emacs-lisp-mode-syntax-table)
  3510.   "*A syntax table for parsing the mailserver URL")
  3511.  
  3512. (modify-syntax-entry ?' "\"" url-mailserver-syntax-table)
  3513. (modify-syntax-entry ?` "\"" url-mailserver-syntax-table)
  3514. (modify-syntax-entry ?< "(>" url-mailserver-syntax-table)
  3515. (modify-syntax-entry ?> ")<" url-mailserver-syntax-table)
  3516. (modify-syntax-entry ?/ " " url-mailserver-syntax-table)
  3517.  
  3518. (defmacro url-mailserver-skip-chunk ()
  3519.   (` (while (and (not (looking-at "/"))
  3520.          (not (eobp)))
  3521.        (forward-sexp 1))))
  3522.  
  3523. (defun url-mailserver (url)
  3524.   ;; Send mail to someone, much cooler/functional than mailto
  3525.   (set-buffer (get-buffer-create " *mailserver*"))
  3526.   (erase-buffer)
  3527.   (insert url)
  3528.   (goto-char (point-min))
  3529.   (set-syntax-table url-mailserver-syntax-table)
  3530.   (skip-chars-forward "^:")        ; Get past mailserver
  3531.   (skip-chars-forward ":")        ; Get past :
  3532.   (let ((save-pos (point))
  3533.     (url (url-view-url t))
  3534.     (rfc822-addr nil)
  3535.     (subject nil)
  3536.     (body nil))
  3537.     (url-mailserver-skip-chunk)
  3538.     (setq rfc822-addr (buffer-substring save-pos (point)))
  3539.     (forward-char 1)
  3540.     (setq save-pos (point))
  3541.     (url-mailserver-skip-chunk)
  3542.     (setq subject (buffer-substring save-pos (point)))
  3543.     (if (not (eobp))
  3544.     (progn                ; There is some text to use
  3545.       (forward-char 1)        ; as the body of the message
  3546.       (setq body (buffer-substring (point) (point-max)))))
  3547.     (if (fboundp url-mail-command) (funcall url-mail-command) (mail))
  3548.     (mail-to)
  3549.     (insert (concat rfc822-addr
  3550.             (if (and url (not (string= url "")))
  3551.             (concat "\nX-URL-From: " url) "")
  3552.             "\nX-User-Agent: " url-package-name "/"
  3553.             url-package-version))
  3554.     (mail-subject)
  3555.     ;; Massage the subject from URLEncoded garbage
  3556.     ;; Note that we do not allow any newlines in the subject,
  3557.     ;; as recommended by the Internet Draft on the mailserver
  3558.     ;; URL - this means the document author cannot spoof additional
  3559.     ;; header lines, which is a 'Good Thing'
  3560.     (if subject
  3561.     (progn
  3562.       (setq subject (url-unhex-string subject))
  3563.       (let ((x (1- (length subject)))
  3564.         (y 0))
  3565.         (while (<= y x)
  3566.           (if (memq (aref subject y) '(?\r ?\n))
  3567.           (aset subject y ? ))
  3568.           (setq y (1+ y))))))
  3569.     (insert subject)
  3570.     (if url-request-extra-headers
  3571.     (progn
  3572.       (goto-char (point-min))
  3573.       (insert
  3574.        (mapconcat
  3575.         (function
  3576.          (lambda (x)
  3577.            (concat (capitalize (car x)) ": " (cdr x) "\n")))
  3578.         url-request-extra-headers ""))))
  3579.     (goto-char (point-max))
  3580.     ;; Massage the body from URLEncoded garbage
  3581.     (if body
  3582.     (let ((x (1- (length body)))
  3583.           (y 0))
  3584.       (while (<= y x)
  3585.         (if (= (aref body y) ?/)
  3586.         (aset body y ?\n))
  3587.         (setq y (1+ y)))
  3588.       (setq body (url-unhex-string body))))
  3589.     (and body (insert body))
  3590.     (and url-request-data (insert url-request-data))
  3591.     (if (and (or body url-request-data)
  3592.          (funcall url-confirmation-func
  3593.               (concat "Send message to " rfc822-addr "? ")))
  3594.     (mail-send-and-exit nil))))    
  3595.  
  3596. (defun url-gopher (url)
  3597.   ;; Handle gopher URLs
  3598.   (let ((descr (url-grok-gopher-href url)))
  3599.     (cond
  3600.      ((or (not (member (nth 1 descr) url-bad-port-list))
  3601.       (funcall
  3602.        url-confirmation-func
  3603.        (format "Warning!  Trying to connect to port %s - continue? "
  3604.            (nth 1 descr))))
  3605.       (if url-use-hypertext-gopher
  3606.       (url-do-gopher descr)
  3607.     (gopher-dispatch-object (vector (if (= 0
  3608.                            (string-to-char (nth 2 descr)))
  3609.                         ?1
  3610.                       (string-to-char (nth 2 descr)))
  3611.                     (nth 2 descr) (nth 2 descr)
  3612.                     (nth 0 descr)
  3613.                     (string-to-int (nth 1 descr)))
  3614.                 (current-buffer))))
  3615.      (t
  3616.       (ding)
  3617.       (url-warn 'security "Aborting connection to bad port...")))))
  3618.  
  3619. (fset 'url-ftp 'url-file)
  3620.  
  3621. (defun url-x-exec (url)
  3622.   ;; Handle local execution of scripts.
  3623.   (set-buffer (get-buffer-create url-working-buffer))
  3624.   (erase-buffer)
  3625.   (string-match "x-exec:/+\\([^/]+\\)\\(/.*\\)" url)
  3626.   (let ((process-environment process-environment)
  3627.     (executable (url-match url 1))
  3628.     (path-info (url-match url 2))
  3629.     (query-string nil)
  3630.     (safe-paths url-local-exec-path)
  3631.     (found nil)
  3632.     (y nil)
  3633.     )
  3634.     (setq url-current-server executable
  3635.       url-current-file path-info)
  3636.     (if (string-match "\\(.*\\)\\?\\(.*\\)" path-info)
  3637.     (setq query-string (url-match path-info 2)
  3638.           path-info (url-match path-info 1)))
  3639.     (while (and safe-paths (not found))
  3640.       (setq y (expand-file-name executable (car safe-paths))
  3641.         found (and (file-exists-p y) (file-executable-p y) y)
  3642.         safe-paths (cdr safe-paths)))
  3643.     (if (not found)
  3644.     (url-retrieve (concat "www://error/nofile/" executable))
  3645.       (setq process-environment
  3646.         (append
  3647.          (list
  3648.           "SERVER_SOFTWARE=x-exec/1.0"
  3649.           (concat "SERVER_NAME=" (system-name))
  3650.           "GATEWAY_INTERFACE=CGI/1.1"
  3651.           "SERVER_PROTOCOL=HTTP/1.0"
  3652.           "SERVER_PORT="
  3653.           (concat "REQUEST_METHOD=" url-request-method)
  3654.           (concat "HTTP_ACCEPT="
  3655.               (mapconcat
  3656.                (function
  3657.             (lambda (x)
  3658.               (cond
  3659.                ((= x ?\n) (setq y t) "")
  3660.                ((= x ?:) (setq y nil) ",")
  3661.                (t (char-to-string x))))) url-mime-accept-string
  3662.                ""))
  3663.           (concat "PATH_INFO=" (url-unhex-string path-info))
  3664.           (concat "PATH_TRANSLATED=" (url-unhex-string path-info))
  3665.           (concat "SCRIPT_NAME=" executable)
  3666.           (concat "QUERY_STRING=" (url-unhex-string query-string))
  3667.           (concat "REMOTE_HOST=" (system-name)))
  3668.          (if (assoc "content-type" url-request-extra-headers)
  3669.          (concat "CONTENT_TYPE=" (cdr
  3670.                       (assoc "content-type"
  3671.                          url-request-extra-headers))))
  3672.          (if url-request-data
  3673.          (concat "CONTENT_LENGTH=" (length url-request-data)))
  3674.          process-environment))
  3675.       (and url-request-data (insert url-request-data))
  3676.       (setq y (call-process-region (point-min) (point-max) found t t))
  3677.       (goto-char (point-min))
  3678.       (delete-region (point) (progn (skip-chars-forward " \t\n") (point)))
  3679.       (cond
  3680.        ((url-mime-response-p) nil)    ; Its already got an HTTP/1.0 header
  3681.        ((null y)            ; Weird exit status, whassup?
  3682.     (insert "HTTP/1.0 404 Not Found\n"
  3683.         "Server: " url-package-name "/x-exec\n"))    
  3684.        ((= 0 y)                ; The shell command was successful
  3685.     (insert "HTTP/1.0 200 Document follows\n"
  3686.         "Server: " url-package-name "/x-exec\n"))    
  3687.        (t                ; Non-zero exit status is bad bad bad
  3688.     (insert "HTTP/1.0 404 Not Found\n"
  3689.         "Server: " url-package-name "/x-exec\n"))))))
  3690.  
  3691.  
  3692. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3693. ;;; Gateway Support
  3694. ;;; ---------------
  3695. ;;; Fairly good/complete gateway support
  3696. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3697. (defun url-kill-process (proc)
  3698.   "Kill the process PROC - knows about all the various gateway types,
  3699. and acts accordingly."
  3700.   (cond
  3701.    ((eq url-gateway-method 'native) (delete-process proc))
  3702.    ((eq url-gateway-method 'program) (kill-process proc))
  3703.    (t (error "Unknown url-gateway-method %s" url-gateway-method))))
  3704.  
  3705. (defun url-accept-process-output (proc)
  3706.   "Allow any pending output from subprocesses to be read by Emacs.
  3707. It is read into the process' buffers or given to their filter functions.
  3708. Where possible, this will not exit until some output is received from PROC,
  3709. or 1 second has elapsed."
  3710.   (if url-current-time-string-has-args
  3711.       (accept-process-output proc 1)
  3712.     (accept-process-output)))
  3713.  
  3714. (defun url-process-status (proc)
  3715.   "Return the process status of a url buffer"
  3716.   (cond
  3717.    ((memq url-gateway-method '(native ssl program)) (process-status proc))
  3718.    (t (error "Unkown url-gateway-method %s" url-gateway-method))))  
  3719.  
  3720. (defun url-open-stream (name buffer host service)
  3721.   "Open a stream to a host"
  3722.   (let ((tmp-gateway-method (if (and url-gateway-local-host-regexp
  3723.                      (not (eq 'ssl url-gateway-method))
  3724.                      (string-match
  3725.                       url-gateway-local-host-regexp
  3726.                       host))
  3727.                 'native
  3728.                   url-gateway-method))
  3729.     (binary-process-output t))
  3730.     (and (eq url-gateway-method 'tcp)
  3731.      (require 'tcp)
  3732.      (setq url-gateway-method 'native
  3733.            tmp-gateway-method 'native))
  3734.     (cond
  3735.      ((eq tmp-gateway-method 'ssl)
  3736.       (open-ssl-stream name buffer host service))
  3737.      ((eq tmp-gateway-method 'native)
  3738.       (if url-broken-resolution
  3739.       (setq host
  3740.         (cond
  3741.          ((featurep 'ange-ftp) (ange-ftp-nslookup-host host))
  3742.          ((featurep 'efs) (efs-nslookup-host host))
  3743.          ((featurep 'efs-auto) (efs-nslookup-host host))
  3744.          (t host))))
  3745.       (let ((retry url-connection-retries)
  3746.         (errobj nil)
  3747.         (conn nil))
  3748.     (while (and (not conn) retry)
  3749.       (condition-case errobj
  3750.           (setq conn (open-network-stream name buffer host service))
  3751.         (error
  3752.          (url-save-error errobj)
  3753.          (save-window-excursion
  3754.            (save-excursion
  3755.          (switch-to-buffer-other-window " *url-error*")
  3756.          (setq retry (funcall url-confirmation-func
  3757.                       (concat "Connection to " host
  3758.                           " failed, retry? "))))))))
  3759.     (if conn
  3760.          (progn
  3761.            (if (boundp 'MULE)
  3762.           (save-excursion
  3763.             (set-buffer (get-buffer-create buffer))
  3764.             (setq mc-flag nil)
  3765.             (set-process-coding-system conn *noconv* *noconv*)))
  3766.            conn)
  3767.       (error "Unable to connect to %s:%s" host service))))
  3768.      ((eq tmp-gateway-method 'program)
  3769.       (let ((proc (start-process name buffer url-gateway-telnet-program host
  3770.                  (int-to-string service)))
  3771.         (tmp nil))
  3772.     (save-excursion
  3773.       (set-buffer buffer)
  3774.       (setq tmp (point))
  3775.       (while (not (progn
  3776.             (goto-char (point-min))
  3777.             (re-search-forward 
  3778.              url-gateway-telnet-ready-regexp nil t)))
  3779.         (url-accept-process-output proc))
  3780.       (delete-region tmp (point))
  3781.       (goto-char (point-min))
  3782.       (if (re-search-forward "connect:" nil t)
  3783.           (progn
  3784.         (condition-case ()
  3785.             (delete-process proc)
  3786.           (error nil))
  3787.         (url-replace-regexp ".*connect:.*" "")
  3788.         nil)
  3789.         proc))))
  3790.      (t (error "Unknown url-gateway-method %s" url-gateway-method)))))
  3791.  
  3792.  
  3793. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3794. ;;; Miscellaneous functions
  3795. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3796. (defun url-setup-privacy-info ()
  3797.   (interactive)
  3798.   (setq url-system-type
  3799.     (cond
  3800.      ((or (eq url-privacy-level 'paranoid)
  3801.           (and (listp url-privacy-level)
  3802.            (memq 'os url-privacy-level)))
  3803.       "NoneOfYourBusiness")
  3804.      ((eq system-type 'Apple-Macintosh) "Macintosh")
  3805.      ((eq system-type 'next-mach) "NeXT")
  3806.      ((eq system-type 'windows-nt) "Windows-NT ; 32bit")
  3807.      ((eq system-type 'ms-windows) "Windows ; 16bit")
  3808.      ((eq system-type 'ms-dos) "MS-DOS ; 32bit")
  3809.      ((and (eq system-type 'vax-vms) (device-type))
  3810.       "VMS ; X11")
  3811.      ((eq system-type 'vax-vms) "VMS ; TTY")
  3812.      ((eq (device-type) 'x) "X11")
  3813.      ((eq (device-type) 'ns) "NeXTStep")
  3814.      ((eq (device-type) 'pm) "OS/2")
  3815.      ((eq (device-type) 'win32) "Windows ; 32bit")
  3816.      ((eq (device-type) 'tty) "(Unix?) ; TTY")
  3817.      (t "UnkownPlatform")))
  3818.  
  3819.   (setq url-personal-mail-address (or url-personal-mail-address
  3820.                       url-pgp/pem-entity))
  3821.  
  3822.   (if (or (memq url-privacy-level '(paranoid high))
  3823.       (and (listp url-privacy-level)
  3824.            (memq 'email url-privacy-level)))
  3825.       (setq url-personal-mail-address nil))
  3826.  
  3827.   (if (or (eq url-privacy-level 'paranoid)
  3828.       (and (listp url-privacy-level)
  3829.            (memq 'os url-privacy-level)))
  3830.       (setq url-os-type "ImNotTelling")
  3831.     (let ((vers (emacs-version)))
  3832.       (if (string-match "(\\([^, )]+\\))$" vers)
  3833.       (setq url-os-type (url-match vers 1))
  3834.     (setq url-os-type (symbol-name system-type))))))
  3835.  
  3836. (defun url-do-setup ()
  3837.   "Do setup - this is to avoid conflict with user settings when URL is
  3838. dumped with emacs."
  3839.   (if url-setup-done
  3840.       nil
  3841.  
  3842.     ;; Register all the protocols we can handle
  3843.     (url-register-protocol 'file)
  3844.     (url-register-protocol 'ftp        nil nil "21")
  3845.     (url-register-protocol 'gopher     nil nil "70")
  3846.     (url-register-protocol 'http       nil nil "80")
  3847.     (url-register-protocol 'https      nil nil "443")
  3848.     (url-register-protocol 'info       nil 'url-identity-expander)
  3849.     (url-register-protocol 'mailserver nil 'url-identity-expander)
  3850.     (url-register-protocol 'finger     nil 'url-identity-expander "79")
  3851.     (url-register-protocol 'mailto     nil 'url-identity-expander)
  3852.     (url-register-protocol 'news       nil 'url-identity-expander "119")
  3853.     (url-register-protocol 'rlogin)
  3854.     (url-register-protocol 'shttp      nil nil "80")
  3855.     (url-register-protocol 'telnet)
  3856.     (url-register-protocol 'tn3270)
  3857.     (url-register-protocol 'wais)
  3858.     (url-register-protocol 'x-exec)
  3859.     (url-register-protocol 'proxy)
  3860.  
  3861.     ;; Register all the authentication schemes we can handle
  3862.     (url-register-auth-scheme "basic" nil 4)
  3863.     (url-register-auth-scheme "digest" nil 7)
  3864.  
  3865.     ;; Filename handler stuff for emacsen that support it
  3866.     (url-setup-file-name-handlers)
  3867.     (setq url-default-session-id (url-create-message-id))
  3868.  
  3869.     (if url-current-time-string-has-args
  3870.     (fset 'url-lazy-message 'url-lazy-message-1)
  3871.       (fset 'url-lazy-message 'url-lazy-message-2))
  3872.     (setq url-global-history-file
  3873.       (or url-global-history-file
  3874.           (and (memq system-type '(ms-dos ms-windows))
  3875.            (expand-file-name "~/mosaic.hst"))
  3876.           (and (memq system-type '(axp-vms vax-vms))
  3877.            (expand-file-name "~/mosaic.global-history"))
  3878.           (condition-case ()
  3879.           (expand-file-name "~/.mosaic-global-history")
  3880.         (error nil))))
  3881.   
  3882.     ;; Parse the global history file if it exists, so that it can be used
  3883.     ;; for URL completion, etc.
  3884.     (if (and url-global-history-file
  3885.          (file-exists-p url-global-history-file))
  3886.     (url-parse-global-history))
  3887.  
  3888.     ;; Read in proxy gateways
  3889.     (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
  3890.             (or (getenv "NO_PROXY")
  3891.                 (getenv "no_PROXY")
  3892.                 (getenv "no_proxy")))))
  3893.       (if noproxy
  3894.       (setq url-proxy-services
  3895.         (cons (cons "no_proxy"
  3896.                 (concat "\\("
  3897.                     (mapconcat
  3898.                      (function
  3899.                       (lambda (x)
  3900.                     (cond
  3901.                      ((= x ?,) "\\|")
  3902.                      ((= x ? ) "")
  3903.                      ((= x ?.) (regexp-quote "."))
  3904.                      ((= x ?*) ".*")
  3905.                      ((= x ??) ".")
  3906.                      (t (char-to-string x)))))
  3907.                      noproxy "") "\\)"))
  3908.               url-proxy-services))))
  3909.  
  3910.     ;; Set the url-use-transparent with decent defaults
  3911.     (if (not (eq (device-type) 'tty))
  3912.     (setq url-use-transparent nil))
  3913.     (and url-use-transparent (require 'transparent))
  3914.   
  3915.     ;; Set the password entry funtion based on user defaults or guess
  3916.     ;; based on which remote-file-access package they are using.
  3917.     (cond
  3918.      (url-passwd-entry-func nil)    ; Already been set
  3919.      ((boundp 'read-passwd)        ; Use secure password if available
  3920.       (setq url-passwd-entry-func 'read-passwd))
  3921.      ((or (featurep 'efs)        ; Using EFS
  3922.       (featurep 'efs-auto))        ; or autoloading efs
  3923.       (if (not (fboundp 'read-passwd))
  3924.       (autoload 'read-passwd "passwd" "Read in a password" nil))
  3925.       (setq url-passwd-entry-func 'read-passwd))
  3926.      ((or (featurep 'ange-ftp)        ; Using ange-ftp
  3927.       (and (boundp 'file-name-handler-alist)
  3928.            (not (string-match "Lucid" (emacs-version)))))
  3929.       (setq url-passwd-entry-func 'ange-ftp-read-passwd))
  3930.      (t
  3931.       (url-warn 'security
  3932.         "Can't determine how to read passwords, winging it.")))
  3933.   
  3934.     ;; Set up the news service if they haven't done so
  3935.     (setq url-news-server
  3936.       (cond
  3937.        (url-news-server url-news-server)
  3938.        ((and (boundp 'gnus-default-nntp-server)
  3939.          (not (equal "" gnus-default-nntp-server)))
  3940.         gnus-default-nntp-server)
  3941.        ((and (boundp 'gnus-nntp-server)
  3942.          (not (null gnus-nntp-server))
  3943.          (not (equal "" gnus-nntp-server)))
  3944.         gnus-nntp-server)
  3945.        ((and (boundp 'nntp-server-name)
  3946.          (not (null nntp-server-name))
  3947.          (not (equal "" nntp-server-name)))
  3948.         nntp-server-name)
  3949.        ((getenv "NNTPSERVER") (getenv "NNTPSERVER"))
  3950.        (t "news")))
  3951.   
  3952.     ;; Set up the MIME accept string if they haven't got it hardcoded yet
  3953.     (or url-mime-accept-string
  3954.     (setq url-mime-accept-string (url-parse-viewer-types)))
  3955.     (or url-mime-encoding-string
  3956.     (setq url-mime-encoding-string
  3957.           (mapconcat 'car
  3958.              mm-content-transfer-encodings
  3959.              ", ")))
  3960.   
  3961.     ;; Set up the entity definition for PGP and PEM authentication
  3962.     (setq url-pgp/pem-entity (or url-pgp/pem-entity
  3963.                  (format "%s@%s"  (user-real-login-name)
  3964.                      (system-name))))
  3965.     (url-setup-privacy-info)
  3966.     (run-hooks 'url-load-hook)
  3967.     (setq url-setup-done t)))
  3968.  
  3969. (defun url-store-in-cache (&optional buff)
  3970.   "Store buffer BUFF in the cache"
  3971.   (if (or (not (get-buffer buff))
  3972.       (member url-current-type '("www" "about" "https" "shttp"
  3973.                      "news" "mailto"))
  3974.       (and (member url-current-type '("file" "ftp" nil))
  3975.            (not url-current-server))
  3976.       )
  3977.       nil
  3978.     (save-excursion
  3979.       (and buff (set-buffer buff))
  3980.       (let* ((fname (url-create-cached-filename (url-view-url t)))
  3981.          (info (mapcar (function (lambda (var)
  3982.                        (cons (symbol-name var)
  3983.                          (symbol-value var))))
  3984.                '( url-current-content-length
  3985.                   url-current-file
  3986.                   url-current-isindex
  3987.                   url-current-mime-encoding
  3988.                   url-current-mime-headers
  3989.                   url-current-mime-type
  3990.                   url-current-mime-viewer
  3991.                   url-current-nntp-server
  3992.                   url-current-port
  3993.                   url-current-server
  3994.                   url-current-type
  3995.                   url-current-user
  3996.                   )))
  3997.          (dir (file-name-directory fname))
  3998.          (done t))
  3999.     (cond
  4000.      ((and (not (file-exists-p dir)) (fboundp 'make-directory))
  4001.       (make-directory dir t))
  4002.      ((and (file-exists-p dir) (not (file-directory-p dir)))
  4003.       (delete-file dir)
  4004.       (make-directory dir t))
  4005.      (t
  4006.       nil))
  4007.     (setq done (file-directory-p (file-name-directory fname)))
  4008.     (if (not done)
  4009.         nil
  4010.       (write-region (point-min) (point-max) fname nil 5)
  4011.       (set-buffer (get-buffer-create " *cache-tmp*"))
  4012.       (erase-buffer)
  4013.       (insert "(setq ")
  4014.       (mapcar
  4015.        (function
  4016.         (lambda (x)
  4017.           (insert (car x) " " (cond
  4018.                    ((null (setq x (cdr x))) "nil")
  4019.                    ((stringp x) (prin1-to-string x))
  4020.                    ((listp x) (concat "'" (prin1-to-string x)))
  4021.                    ((numberp x) (int-to-string x))
  4022.                    (t "'???")) "\n")))
  4023.        info)
  4024.       (insert ")\n")
  4025.       (write-region (point-min) (point-max)
  4026.             (concat (if (memq system-type '(ms-windows ms-dos os2))
  4027.                     (url-file-extension fname t)
  4028.                   fname) ".hdr") nil
  4029.             5))))))
  4030.  
  4031. (defun url-is-cached (url)
  4032.   "Return non-nil if the URL is cached."
  4033.   (let ((fname (url-create-cached-filename url)))
  4034.     (and fname (file-exists-p fname) (nth 5 (file-attributes fname)))))
  4035.  
  4036. (defun url-create-cached-filename-using-md5 (url)
  4037.   (if url
  4038.       (expand-file-name (md5 url)
  4039.             (concat url-temporary-directory "/"
  4040.                 (user-real-login-name)))))
  4041.  
  4042. (defun url-create-cached-filename (url)
  4043.   "Return a filename in the local cache for URL"
  4044.   (if url
  4045.       (let* ((url url)
  4046.          (urlobj (if (vectorp url)
  4047.              url
  4048.                (url-generic-parse-url url)))
  4049.          (protocol (url-type urlobj))
  4050.          (hostname (url-host urlobj))
  4051.          (host-components
  4052.           (cons
  4053.            (user-real-login-name)
  4054.            (cons (or protocol "file")
  4055.              (nreverse
  4056.               (delq nil
  4057.                 (mm-string-to-tokens
  4058.                  (or hostname "localhost") ?.))))))
  4059.          (fname    (url-filename urlobj)))
  4060.     (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/))
  4061.         (setq fname (substring fname 1 nil)))
  4062.     (if fname
  4063.         (let ((slash nil))
  4064.           (setq fname
  4065.             (mapconcat
  4066.              (function
  4067.               (lambda (x)
  4068.             (cond
  4069.              ((and (= ?/ x) slash)
  4070.               (setq slash nil)
  4071.               "%2F")
  4072.              ((= ?/ x)
  4073.               (setq slash t)
  4074.               "/")
  4075.              (t
  4076.               (setq slash nil)
  4077.               (char-to-string x))))) fname ""))))
  4078.  
  4079.     (if (and fname (memq system-type '(ms-windows ms-dos windows-nt))
  4080.          (string-match "\\([A-Za-z]\\):[/\\]" fname))
  4081.         (setq fname (concat (url-match fname 1) "/"
  4082.                 (substring fname (match-end 0)))))
  4083.     
  4084.     (setq fname (and fname
  4085.              (mapconcat
  4086.               (function (lambda (x)
  4087.                       (if (= x ?~) "" (char-to-string x))))
  4088.               fname ""))
  4089.           fname (cond
  4090.              ((null fname) nil)
  4091.              ((or (string= "" fname) (string= "/" fname))
  4092.               url-directory-index-file)
  4093.              ((= (string-to-char fname) ?/)
  4094.               (if (string= (substring fname -1 nil) "/")
  4095.               (concat fname url-directory-index-file)
  4096.             (substring fname 1 nil)))
  4097.              (t
  4098.               (if (string= (substring fname -1 nil) "/")
  4099.               (concat fname url-directory-index-file)
  4100.             fname))))
  4101.  
  4102.     ;; Honor hideous 8.3 filename limitations on dos and windows
  4103.     ;; we don't have to worry about this in Windows NT/95 (or OS/2?)
  4104.     (if (and fname (memq system-type '(ms-windows ms-dos)))
  4105.         (let ((base (url-file-extension fname t))
  4106.           (ext  (url-file-extension fname nil)))
  4107.           (setq fname (concat (substring base 0 (min 8 (length base)))
  4108.                   (substring ext  0 (min 4 (length ext)))))
  4109.           (setq host-components
  4110.             (mapcar
  4111.              (function
  4112.               (lambda (x)
  4113.             (if (> (length x) 8)
  4114.                 (concat 
  4115.                  (substring x 0 8) "."
  4116.                  (substring x 8 (min (length x) 11)))
  4117.               x)))
  4118.              host-components))))
  4119.  
  4120.     (and fname
  4121.          (expand-file-name fname
  4122.                    (expand-file-name
  4123.                 (mapconcat 'identity host-components "/")
  4124.                 url-temporary-directory))))))
  4125.  
  4126. (defun url-extract-from-cache (fnam)
  4127.   "Extract FNAM from the local disk cache"
  4128.   (set-buffer (get-buffer-create url-working-buffer))
  4129.   (erase-buffer)
  4130.   (setq url-current-mime-viewer nil)
  4131.   (cond
  4132.    ((or (null url-request-method)
  4133.     (string= url-request-method "GET"))
  4134.     (mm-insert-file-contents fnam)
  4135.     (load-file (concat
  4136.         (if (memq system-type '(ms-windows ms-dos os2))
  4137.             (url-file-extension fnam t)
  4138.           fnam) ".hdr")))
  4139.    ((string= url-request-method "HEAD")
  4140.     (load-file (concat (if (memq system-type '(ms-windows ms-dos os2))
  4141.                (url-file-extension fnam t)
  4142.              fnam) ".hdr"))
  4143.     (insert
  4144.      (mapconcat
  4145.       (function
  4146.        (lambda (hdr)
  4147.      (if (equal (car hdr) "") ""
  4148.        (concat (capitalize (car hdr)) ": " (cdr hdr)))))
  4149.       url-current-mime-headers "\n"))))
  4150.   (message "Extracted %s from cache" url-current-file))
  4151.  
  4152. ;;;###autoload
  4153. (defun url-get-url-at-point (&optional pt)
  4154.   "Get the URL closest to point, but don't change your
  4155. position. Has a preference for looking backward when not
  4156. directly on a symbol."
  4157.   ;; Not at all perfect - point must be right in the name.
  4158.   (save-excursion
  4159.     (if pt (goto-char pt))
  4160.     (let ((filename-chars "%.?@a-zA-Z0-9---()_/:~=&") start url)
  4161.       (save-excursion
  4162.     ;; first see if you're just past a filename
  4163.     (if (not (eobp))
  4164.         (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens
  4165.         (progn
  4166.           (skip-chars-backward " \n\t\r({[]})")
  4167.           (if (not (bobp))
  4168.               (backward-char 1)))))
  4169.     (if (string-match (concat "[" filename-chars "]")
  4170.               (char-to-string (following-char)))
  4171.         (progn
  4172.           (skip-chars-backward filename-chars)
  4173.           (setq start (point))
  4174.           (skip-chars-forward filename-chars))
  4175.       (message "No URL found around point!")
  4176.       (setq start (point)))
  4177.     (setq url (if (fboundp 'buffer-substring-no-properties)
  4178.               (buffer-substring-no-properties start (point))
  4179.             (buffer-substring start (point)))))
  4180.       (if (string-match "^URL:" url)
  4181.       (setq url (substring url 4 nil)))
  4182.       (if (not (string-match url-nonrelative-link url))
  4183.       (setq url nil))
  4184.       url)))
  4185.  
  4186. (defun url-eat-trailing-space (x)
  4187.   ;; Remove spaces/tabs at the end of a string
  4188.   (let ((y (1- (length x)))
  4189.     (skip-chars (list ?  ?\t ?\n)))
  4190.     (while (and (>= y 0) (memq (aref x y) skip-chars))
  4191.       (setq y (1- y)))
  4192.     (substring x 0 (1+ y))))
  4193.  
  4194. (defun url-strip-leading-spaces (x)
  4195.   ;; Remove spaces at the front of a string
  4196.   (let ((y (1- (length x)))
  4197.     (z 0)
  4198.     (skip-chars (list ?  ?\t ?\n)))
  4199.     (while (and (<= z y) (memq (aref x z) skip-chars))
  4200.       (setq z (1+ z)))
  4201.     (substring x z nil)))
  4202.  
  4203. (defun url-convert-newlines-to-spaces (x)
  4204.   "Convert newlines and carriage returns embedded in a string into spaces,
  4205. and swallow following whitespace.
  4206. The argument is not side-effected, but may be returned by this function."
  4207.   (if (string-match "[\n\r]+\\s-*" x)   ; [\\n\\r\\t ]
  4208.       (concat (substring x 0 (match-beginning 0)) " "
  4209.           (url-convert-newlines-to-spaces
  4210.            (substring x (match-end 0))))
  4211.     x))
  4212.  
  4213. ;; Test cases
  4214. ;; (url-convert-newlines-to-spaces "foo    bar")  ; nothing happens
  4215. ;; (url-convert-newlines-to-spaces "foo\n  \t  bar") ; whitespace converted
  4216. ;;
  4217. ;; This implementation doesn't mangle the match-data, is fast, and doesn't
  4218. ;; create garbage, but it leaves whitespace.
  4219. ;; (defun url-convert-newlines-to-spaces (x)
  4220. ;;   "Convert newlines and carriage returns embedded in a string into spaces.
  4221. ;; The string is side-effected, then returned."
  4222. ;;   (let ((i 0)
  4223. ;;      (limit (length x)))
  4224. ;;     (while (< i limit)
  4225. ;;       (if (or (= ?\n (aref x i))
  4226. ;;            (= ?\r (aref x i)))
  4227. ;;        (aset x i ? ))
  4228. ;;       (setq i (1+ i)))
  4229. ;;     x))
  4230.  
  4231. (defun url-expand-file-name (url &optional default)
  4232.   "Convert URL to a fully specified URL, and canonicalize it.
  4233. Second arg DEFAULT is a URL to start with if URL is relative.
  4234. If DEFAULT is nil or missing, the current buffer's URL is used.
  4235. Path components that are `.' are removed, and 
  4236. path components followed by `..' are removed, along with the `..' itself."
  4237.   (if url
  4238.       (setq url (mapconcat (function (lambda (x)
  4239.                        (if (= x ?\n) "" (char-to-string x))))
  4240.                (url-strip-leading-spaces
  4241.                 (url-eat-trailing-space url)) "")))
  4242.   (cond
  4243.    ((null url) nil)            ; Something hosed!  Be graceful
  4244.    ((string-match "^#" url)        ; Offset link, use it raw
  4245.     url)
  4246.    (t
  4247.     (let* ((urlobj (url-generic-parse-url url))
  4248.        (inhibit-file-name-handlers t)
  4249.        (defobj (cond
  4250.             ((vectorp default) default)
  4251.             (default (url-generic-parse-url default))
  4252.             ((and (null default) url-current-object)
  4253.              url-current-object)
  4254.             (t (url-generic-parse-url (url-view-url t)))))
  4255.        (expander (cdr-safe
  4256.               (cdr-safe
  4257.                (assoc (or (url-type urlobj)
  4258.                   (url-type defobj))
  4259.                   url-registered-protocols)))))
  4260.       (if (fboundp expander)
  4261.       (funcall expander urlobj defobj)
  4262.     (message "Unknown URL scheme: %s" (or (url-type urlobj)
  4263.                          (url-type defobj)))
  4264.     (url-identity-expander urlobj defobj))
  4265.       (url-recreate-url urlobj)))))
  4266.  
  4267. (defun url-default-expander (urlobj defobj)
  4268.   ;; The default expansion routine - urlobj is modified by side effect!
  4269.   (url-set-type urlobj (or (url-type urlobj) (url-type defobj)))
  4270.   (url-set-port urlobj (or (url-port urlobj)
  4271.                (and (string= (url-type urlobj)
  4272.                      (url-type defobj))
  4273.                 (url-port defobj))))
  4274.   (if (not (string= "file" (url-type urlobj)))
  4275.       (url-set-host urlobj (or (url-host urlobj) (url-host defobj))))
  4276.   (if (string-match "^/" (url-filename urlobj))
  4277.       nil
  4278.     (url-set-filename urlobj
  4279.               (url-remove-relative-links
  4280.                (concat (url-basepath (url-filename defobj))
  4281.                    (url-filename urlobj))))))
  4282.  
  4283. (defun url-identity-expander (urlobj defobj)
  4284.   (url-set-type urlobj (or (url-type urlobj) (url-type defobj))))
  4285.  
  4286. (defun url-hexify-string (str)
  4287.   "Escape characters in a string"
  4288.   (if (and (boundp 'MULE) str)
  4289.       (setq str (code-convert-string 
  4290.           str *internal* url-mule-retrieval-coding-system)))
  4291.   (setq str (mapconcat
  4292.          (function
  4293.           (lambda (char)
  4294.         (if (or (> char ?z)
  4295.             (< char ?-)
  4296.             (and (< char ?a)
  4297.                  (> char ?Z))
  4298.             (and (< char ?@)
  4299.                  (> char ?:)))
  4300.             (if (< char 16)
  4301.             (upcase (format "%%0%x" char))
  4302.               (upcase (format "%%%x" char)))
  4303.           (char-to-string char)))) str "")))
  4304.  
  4305. (defun url-make-sequence (start end)
  4306.   "Make a sequence (list) of numbers from START to END"
  4307.   (cond
  4308.    ((= start end) '())
  4309.    ((> start end) '())
  4310.    (t
  4311.     (let ((sqnc '()))
  4312.       (while (<= start end)
  4313.     (setq sqnc (cons end sqnc)
  4314.           end (1- end)))
  4315.       sqnc))))
  4316.  
  4317. (defun url-file-extension (fname &optional x)
  4318.   "Return the filename extension of FNAME.  If optional variable X is t,
  4319. then return the basename of the file with the extension stripped off."
  4320.   (if (and fname (string-match "\\.[^./]+$" fname))
  4321.       (if x (substring fname 0 (match-beginning 0))
  4322.     (substring fname (match-beginning 0) nil))
  4323.     ;;
  4324.     ;; If fname has no extension, and x then return fname itself instead of 
  4325.     ;; nothing. When caching it allows the correct .hdr file to be produced
  4326.     ;; for filenames without extension.
  4327.     ;;
  4328.     (if x
  4329.      fname
  4330.       "")))
  4331.  
  4332. (defun url-basepath (file &optional x)
  4333.   "Return the base pathname of FILE, or the actual filename if X is true"
  4334.   (cond
  4335.    ((null file) "")
  4336.    (x (file-name-nondirectory file))
  4337.    (t (file-name-directory file))))
  4338.  
  4339. (defun url-unhex (x)
  4340.   (if (> x ?9)
  4341.       (if (>= x ?a)
  4342.       (+ 10 (- x ?a))
  4343.     (+ 10 (- x ?A)))
  4344.     (- x ?0)))
  4345.  
  4346. (defun url-unhex-string (str)
  4347.   "Remove %XXX embedded spaces, etc in a url"
  4348.   (setq str (or str ""))
  4349.   (let ((tmp ""))
  4350.     (while (string-match "%[0-9a-f][0-9a-f]" str)
  4351.       (let* ((start (match-beginning 0))
  4352.          (ch1 (url-unhex (elt str (+ start 1))))
  4353.          (code (+ (* 16 ch1)
  4354.               (url-unhex (elt str (+ start 2))))))
  4355.     (setq tmp
  4356.           (concat 
  4357.            tmp (substring str 0 start)
  4358.            (if (or (= code ?\n) (= code ?\r)) " " (char-to-string code)))
  4359.           str (substring str (match-end 0)))))
  4360.     (setq tmp (concat tmp str))
  4361.     tmp))
  4362.  
  4363. (defun url-clean-text ()
  4364.   "Clean up a buffer, removing any excess garbage from a gateway mechanism,
  4365. and decoding any MIME content-transfer-encoding used."
  4366.   (set-buffer url-working-buffer)
  4367.   (goto-char (point-min))
  4368.   (skip-chars-forward (if (memq url-gateway-method '(host program))
  4369.               " \t\n" "\n"))
  4370.   (delete-region (point) (point-min))
  4371.   (url-replace-regexp "Connection closed by.*" "")
  4372.   (url-replace-regexp "Process WWW.*" ""))
  4373.  
  4374. (defun url-uncompress ()
  4375.   "Do any necessary uncompression on `url-working-buffer'"
  4376.   (set-buffer url-working-buffer)
  4377.   (if (not url-inhibit-uncompression)
  4378.       (let* ((extn (url-file-extension url-current-file))
  4379.          (decoder nil)
  4380.          (code-1 (cdr-safe
  4381.               (assoc "content-transfer-encoding"
  4382.                  url-current-mime-headers)))
  4383.          (code-2 (cdr-safe
  4384.               (assoc "content-encoding" url-current-mime-headers)))
  4385.          (code-3 (and (not code-1) (not code-2)
  4386.               (cdr-safe (assoc extn url-uncompressor-alist))))
  4387.          (done nil)
  4388.          (default-process-coding-system
  4389.            (if (boundp 'MULE) (cons *noconv* *noconv*))))
  4390.     (mapcar
  4391.      (function
  4392.       (lambda (code)
  4393.         (setq decoder (and (not (member code done))
  4394.                    (cdr-safe
  4395.                 (assoc code mm-content-transfer-encodings)))
  4396.           done (cons code done))
  4397.         (cond
  4398.          ((null decoder) nil)
  4399.          ((stringp decoder)
  4400.           (message "Decoding...")
  4401.           (call-process-region (point-min) (point-max) decoder t t nil)
  4402.           (message "Decoding... done."))
  4403.          ((listp decoder)
  4404.           (apply 'call-process-region (point-min) (point-max)
  4405.              (car decoder) t t nil (cdr decoder)))
  4406.          ((and (symbolp decoder) (fboundp decoder))
  4407.           (message "Decoding...")
  4408.           (funcall decoder (point-min) (point-max))
  4409.           (message "Decoding... done."))
  4410.          (t
  4411.           (error "Bad entry for %s in `mm-content-transfer-encodings'"
  4412.              code)))))
  4413.      (list code-1 code-2 code-3))))
  4414.   (set-buffer-modified-p nil))
  4415.  
  4416. (defun url-filter (proc string)
  4417.   (save-excursion
  4418.     (set-buffer url-working-buffer)
  4419.     (insert string)
  4420.     (if (string-match "\nConnection closed by" string)
  4421.     (progn (set-process-filter proc nil)
  4422.            (url-sentinel proc string))))
  4423.   string)
  4424.  
  4425. (defun url-sentinel (proc string)
  4426.   (set-buffer (get-buffer (process-buffer proc)))
  4427.   (if (boundp 'after-change-functions)
  4428.       (remove-hook 'after-change-functions 'url-after-change-function))
  4429.   (let ((status nil))
  4430.     (if url-be-asynchronous
  4431.     (progn
  4432.       (url-clean-text)
  4433.       (cond
  4434.        ((and (null proc) (not (get-buffer url-working-buffer))) nil)
  4435.        ((url-mime-response-p) (setq status (url-parse-mime-headers))))
  4436.       (if (not url-current-mime-type)
  4437.           (setq url-current-mime-type (mm-extension-to-mime
  4438.                        (url-file-extension
  4439.                         url-current-file))))))
  4440.     (if (member status '(401 301 302 303 204))
  4441.     nil
  4442.       (funcall url-default-retrieval-proc (buffer-name)))))
  4443.  
  4444. (defun url-remove-relative-links (name)
  4445.   ;; Strip . and .. from pathnames
  4446.   (let ((new (if (not (string-match "^/" name))
  4447.          (concat "/" name)
  4448.            name)))
  4449.     (while (string-match "/\\([^/]*/\\.\\./\\)" new)
  4450.       (setq new (concat (substring new 0 (match-beginning 1))
  4451.             (substring new (match-end 1)))))
  4452.     (while (string-match "/\\(\\./\\)" new)
  4453.       (setq new (concat (substring new 0 (match-beginning 1))
  4454.             (substring new (match-end 1)))))
  4455.     new))
  4456.  
  4457. (defun url-view-url (&optional no-show)
  4458.   "View the current document's URL.  Optional argument NO-SHOW means
  4459. just return the URL, don't show it in the minibuffer."
  4460.   (interactive)
  4461.   (let ((url ""))
  4462.     (cond
  4463.      ((equal url-current-type "gopher")
  4464.       (setq url (format "%s://%s%s/%s"
  4465.             url-current-type url-current-server
  4466.             (if (or (null url-current-port)
  4467.                 (string= "70" url-current-port)) ""
  4468.               (concat ":" url-current-port))
  4469.             url-current-file)))
  4470.      ((equal url-current-type "news")
  4471.       (setq url (concat "news:"
  4472.             (if (not (equal url-current-server
  4473.                     url-news-server))
  4474.                 (concat "//" url-current-server
  4475.                     (if (or (null url-current-port)
  4476.                         (string= "119" url-current-port))
  4477.                     ""
  4478.                       (concat ":" url-current-port)) "/"))
  4479.             url-current-file)))
  4480.      ((equal url-current-type "about")
  4481.       (setq url (concat "about:" url-current-file)))
  4482.      ((member url-current-type '("http" "shttp" "https"))
  4483.       (setq url (format  "%s://%s%s/%s" url-current-type url-current-server
  4484.              (if (or (null url-current-port)
  4485.                  (string= "80" url-current-port))
  4486.                  ""
  4487.                (concat ":" url-current-port))
  4488.              (if (and url-current-file
  4489.                   (= ?/ (string-to-char url-current-file)))
  4490.                  (substring url-current-file 1 nil)
  4491.                url-current-file))))
  4492.      ((equal url-current-type "ftp")
  4493.       (setq url (format "%s://%s%s/%s" url-current-type
  4494.             (if (and url-current-user
  4495.                  (not (string= "anonymous" url-current-user)))
  4496.                 (concat url-current-user "@") "")
  4497.             url-current-server
  4498.             (if (and url-current-file
  4499.                  (= ?/ (string-to-char url-current-file)))
  4500.                 (substring url-current-file 1 nil)
  4501.               url-current-file))))
  4502.      ((and (member url-current-type '("file" nil)) url-current-file)
  4503.       (setq url (format "file:%s" url-current-file)))
  4504.      ((equal url-current-type "www")
  4505.       (setq url (format "www:/%s/%s" url-current-server url-current-file))))
  4506.     (if (not no-show) (message "%s" url) url)))
  4507.  
  4508. (defun url-parse-Netscape-history (fname)
  4509.   ;; Parse a Netscape/X style global history list.
  4510.   (let (pos                ; Position holder
  4511.     url                ; The URL
  4512.     time)                ; Last time accessed
  4513.     (goto-char (point-min))
  4514.     (skip-chars-forward "^\n")
  4515.     (skip-chars-forward "\n \t")    ; Skip past the tag line
  4516.     ;; Here we will go to the end of the line and
  4517.     ;; skip back over a token, since we might run
  4518.     ;; into spaces in URLs, depending on how much
  4519.     ;; smarter netscape is than the old XMosaic :)
  4520.     (while (not (eobp))
  4521.       (setq pos (point))
  4522.       (end-of-line)
  4523.       (skip-chars-backward "^ \t")
  4524.       (skip-chars-backward " \t")
  4525.       (setq url (buffer-substring pos (point))
  4526.         pos (1+ (point)))
  4527.       (skip-chars-forward "^\n")
  4528.       (setq time (buffer-substring pos (point)))
  4529.       (skip-chars-forward "\n")
  4530.       (setq url-global-history-completion-list
  4531.         (cons (cons url time)
  4532.           url-global-history-completion-list)))))
  4533.  
  4534. (defun url-parse-Mosaic-history (fname)
  4535.   ;; Parse an NCSA Mosaic/X style global history list
  4536.   (goto-char (point-min))
  4537.   (skip-chars-forward "^\n")
  4538.   (skip-chars-forward "\n \t")    ; Skip past the tag line
  4539.   (skip-chars-forward "^\n")
  4540.   (skip-chars-forward "\n \t")    ; Skip past the second tag line
  4541.   (let (pos                ; Temporary position holder
  4542.     bol                ; Beginning-of-line
  4543.     url                ; URL
  4544.     time                ; Time
  4545.     last-end            ; Last ending point
  4546.     )
  4547.     (while (not (eobp))
  4548.       (setq bol (point))
  4549.       (end-of-line)
  4550.       (setq pos (point)
  4551.         last-end (point))
  4552.       (skip-chars-backward "^ \t" bol)    ; Skip over year
  4553.       (skip-chars-backward " \t" bol)
  4554.       (skip-chars-backward "^ \t" bol)    ; Skip over time
  4555.       (skip-chars-backward " \t" bol)
  4556.       (skip-chars-backward "^ \t" bol)    ; Skip over day #
  4557.       (skip-chars-backward " \t" bol)
  4558.       (skip-chars-backward "^ \t" bol)    ; Skip over month
  4559.       (skip-chars-backward " \t" bol)
  4560.       (skip-chars-backward "^ \t" bol)    ; Skip over day abbrev.
  4561.       (if (bolp)
  4562.       nil                ; Malformed entry!!! Ack! Bailout!
  4563.     (setq time (buffer-substring pos (point)))
  4564.     (skip-chars-backward " \t")
  4565.     (setq pos (point)))
  4566.       (beginning-of-line)
  4567.       (setq url (buffer-substring (point) pos))
  4568.       (goto-char (min (1+ last-end) (point-max))) ; Goto next line
  4569.       (if (/= (length url) 0)
  4570.       (setq url-global-history-completion-list
  4571.         (cons (cons url time)
  4572.               url-global-history-completion-list))))))
  4573.  
  4574. (defun url-parse-Emacs-history (&optional fname)
  4575.   ;; Parse out the Emacs-w3 global history file for completion, etc.
  4576.   (or fname (setq fname (expand-file-name url-global-history-file)))
  4577.   (cond
  4578.    ((not (file-exists-p fname))
  4579.     (message "%s does not exist." fname))
  4580.    ((not (file-readable-p fname))
  4581.     (message "%s is unreadable." fname))
  4582.    (t
  4583.     (condition-case ()
  4584.     (load fname nil t)
  4585.       (error (message "Could not load %s" fname))))))
  4586.  
  4587. (defun url-parse-global-history (&optional fname)
  4588.   ;; Parse out the mosaic global history file for completions, etc.
  4589.   (or fname (setq fname (expand-file-name url-global-history-file)))
  4590.   (cond
  4591.    ((not (file-exists-p fname))
  4592.     (message "%s does not exist." fname))
  4593.    ((not (file-readable-p fname))
  4594.     (message "%s is unreadable." fname))
  4595.    (t
  4596.     (save-excursion
  4597.       (set-buffer (get-buffer-create " *url-tmp*"))
  4598.       (erase-buffer)
  4599.       (mm-insert-file-contents fname)
  4600.       (goto-char (point-min))
  4601.       (cond
  4602.        ((looking-at "(setq") (url-parse-Emacs-history fname))
  4603.        ((looking-at "ncsa-mosaic") (url-parse-Mosaic-history fname))
  4604.        ((or (looking-at "MCOM-") (looking-at "netscape"))
  4605.     (url-parse-Netscape-history fname))
  4606.        (t
  4607.     (url-warn 'url "Cannot deduce type of history file: %s" fname)))))))
  4608.  
  4609. (defun url-write-Emacs-history (fname)
  4610.   ;; Write an Emacs-w3 style global history list into FNAME
  4611.   (erase-buffer)
  4612.   (insert "(setq url-global-history-completion-list '")
  4613.   (if (fboundp 'pp)
  4614.       (insert (pp url-global-history-completion-list))
  4615.     (insert (prin1-to-string  url-global-history-completion-list)))
  4616.   (insert "\n)")
  4617.   (write-file url-global-history-file))
  4618.  
  4619. (defun url-write-Netscape-history (fname)
  4620.   ;; Write a Netscape-style global history list into FNAME
  4621.   (erase-buffer)
  4622.   (let ((tmp url-global-history-completion-list)
  4623.     url                ; The URL
  4624.     time                ; Last accessed time
  4625.     (last-valid-time "785305714"))    ; Picked out of thin air,
  4626.                     ; in case first in assoc list
  4627.                     ; doesn't have a valid time
  4628.     (goto-char (point-min))
  4629.     (insert "MCOM-Global-history-file-1\n")
  4630.     (while tmp
  4631.       (setq url (car (car tmp))
  4632.         time (cdr (car tmp)))
  4633.       (if (or (not (stringp time)) (string-match " \t" time))
  4634.       (setq time last-valid-time)
  4635.     (setq last-valid-time time))
  4636.       (insert (concat url " " time "\n"))
  4637.       (setq tmp (cdr tmp)))
  4638.     (write-file url-global-history-file)))
  4639.  
  4640. (defun url-write-Mosaic-history (fname)
  4641.   ;; Write a Mosaic/X-style global history list into FNAME
  4642.   (erase-buffer)
  4643.   (let ((tmp url-global-history-completion-list)
  4644.     url
  4645.     time)
  4646.     (goto-char (point-min))
  4647.     (insert "ncsa-mosaic-history-format-1\nGlobal\n")
  4648.     (while tmp
  4649.       (setq url (car (car tmp))
  4650.         time (cdr (car tmp)))
  4651.       (if (and (listp time) url-current-time-string-has-args)
  4652.       (setq time (current-time-string time)))
  4653.       (if (or (not (stringp time))
  4654.           (not (string-match " " time)))
  4655.       (setq time (current-time-string)))
  4656.       (insert (concat url " " time "\n"))
  4657.       (setq tmp (cdr tmp)))
  4658.     (write-file url-global-history-file)))
  4659.  
  4660. (defun url-write-global-history (&optional fname)
  4661.   "Write the global history file into `url-global-history-file'.
  4662. The type of data written is determined by what is in the file to begin
  4663. with.  If the type of storage cannot be determined, then prompt the
  4664. user for what type to save as."
  4665.   (interactive)
  4666.   (or fname (setq fname (expand-file-name url-global-history-file)))
  4667.   (cond
  4668.    ((not (file-writable-p fname))
  4669.     (message "%s is unwritable." fname))
  4670.    (t
  4671.     (save-excursion
  4672.       (set-buffer (get-buffer-create " *url-tmp*"))
  4673.       (erase-buffer)
  4674.       (condition-case ()
  4675.       (mm-insert-file-contents fname)
  4676.     (error nil))
  4677.       (goto-char (point-min))
  4678.       (cond
  4679.        ((looking-at "ncsa-mosaic") (url-write-Mosaic-history fname))
  4680.        ((looking-at "MCOM-") (url-write-Netscape-history fname))
  4681.        ((looking-at "netscape") (url-write-Netscape-history fname))
  4682.        ((looking-at "(setq") (url-write-Emacs-history fname))
  4683.        (t
  4684.     (let* ((opts '(("Netscape" . url-write-Netscape-history)
  4685.                ("Mosaic"   . url-write-Mosaic-history)
  4686.                ("Emacs"    . url-write-Emacs-history)))
  4687.            (val (completing-read "Save history in what format: "
  4688.                      opts nil t (cons "Mosaic" 0) nil)))
  4689.       (if (string= val "")
  4690.           nil
  4691.         (funcall (cdr (assoc val opts)) fname)))))
  4692.       (kill-buffer (current-buffer))))))
  4693.  
  4694.  
  4695. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4696. ;;; The main URL fetching interface
  4697. ;;; -------------------------------
  4698. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4699.  
  4700. ;;;###autoload
  4701. (defun url-popup-info (url)
  4702.   "Retrieve the HTTP/1.0 headers and display them in a temp buffer."
  4703.   (let* ((urlobj (url-generic-parse-url url))
  4704.      (type (url-type urlobj))
  4705.      data)
  4706.     (cond
  4707.      ((string= type "http")
  4708.       (let ((url-request-method "HEAD")
  4709.         (url-automatic-caching nil)
  4710.         (url-inhibit-mime-parsing t)
  4711.         (url-working-buffer " *popup*"))
  4712.     (save-excursion
  4713.       (set-buffer (get-buffer-create url-working-buffer))
  4714.       (erase-buffer)
  4715.       (setq url-be-asynchronous nil)
  4716.       (url-retrieve url)
  4717.       (subst-char-in-region (point-min) (point-max) ?\r ? )
  4718.       (buffer-string))))
  4719.      ((or (string= type "file") (string= type "ftp"))
  4720.       (setq data (url-file-attributes url))
  4721.       (set-buffer (get-buffer-create
  4722.            (url-generate-new-buffer-name "*Header Info*")))
  4723.       (erase-buffer)
  4724.       (if data
  4725.       (concat (if (stringp (nth 0 data))
  4726.               (concat "    Linked to: " (nth 0 data))
  4727.             (concat "    Directory: " (if (nth 0 data) "Yes" "No")))
  4728.           "\n        Links: " (int-to-string (nth 1 data))
  4729.           "\n     File UID: " (int-to-string (nth 2 data))
  4730.           "\n     File GID: " (int-to-string (nth 3 data))
  4731.           (if url-current-time-string-has-args
  4732.               (concat
  4733.                "\n  Last Access: " (current-time-string (nth 4 data))
  4734.                "\nLast Modified: " (current-time-string (nth 5 data))
  4735.                "\n Last Changed: " (current-time-string (nth 6 data)))
  4736.             "")
  4737.           "\n Size (bytes): " (int-to-string (nth 7 data))
  4738.           "\n    File Type: " (or (nth 8 data) "text/plain"))
  4739.     (concat "No info found for " url)))
  4740.      ((and (string= type "news") (string-match "@" url))
  4741.       (let ((art (url-filename urlobj)))
  4742.     (if (not (string= (substring art -1 nil) ">"))
  4743.         (setq art (concat "<" art ">")))
  4744.     (url-get-headers-from-article-id art)))
  4745.      (t (concat "Don't know how to find information on " url)))))
  4746.  
  4747. (defun url-decode-text ()
  4748.   ;; Decode text transmitted by NNTP.
  4749.   ;; 0. Delete status line.
  4750.   ;; 1. Delete `^M' at end of line.
  4751.   ;; 2. Delete `.' at end of buffer (end of text mark).
  4752.   ;; 3. Delete `.' at beginning of line."
  4753.   (save-excursion
  4754.     (set-buffer nntp-server-buffer)
  4755.     ;; Insert newline at end of buffer.
  4756.     (goto-char (point-max))
  4757.     (if (not (bolp))
  4758.     (insert "\n"))
  4759.     ;; Delete status line.
  4760.     (goto-char (point-min))
  4761.     (delete-region (point) (progn (forward-line 1) (point)))
  4762.     ;; Delete `^M' at end of line.
  4763.     ;; (replace-regexp "\r$" "")
  4764.     (while (not (eobp))
  4765.       (end-of-line)
  4766.       (if (= (preceding-char) ?\r)
  4767.       (delete-char -1))
  4768.       (forward-line 1)
  4769.       )
  4770.     ;; Delete `.' at end of buffer (end of text mark).
  4771.     (goto-char (point-max))
  4772.     (forward-line -1)            ;(beginning-of-line)
  4773.     (if (looking-at "^\\.$")
  4774.     (delete-region (point) (progn (forward-line 1) (point))))
  4775.     ;; Replace `..' at beginning of line with `.'.
  4776.     (goto-char (point-min))
  4777.     ;; (replace-regexp "^\\.\\." ".")
  4778.     (while (search-forward "\n.." nil t)
  4779.       (delete-char -1))
  4780.     ))
  4781.  
  4782. (defun url-get-headers-from-article-id (art)
  4783.   ;; Return the HEAD of ART (a usenet news article)
  4784.   (cond
  4785.    ((string-match "flee" nntp-version)
  4786.     (nntp/command "HEAD" art)
  4787.     (save-excursion
  4788.       (set-buffer nntp-server-buffer)
  4789.       (while (progn (goto-char (point-min))
  4790.             (not (re-search-forward "^.\r*$" nil t)))
  4791.     (url-accept-process-output nntp/connection))))
  4792.    (t
  4793.     (nntp-send-command "^\\.\r$" "HEAD" art)
  4794.     (url-decode-text)))
  4795.   (save-excursion
  4796.     (set-buffer nntp-server-buffer)
  4797.     (buffer-string)))
  4798.  
  4799. (defvar url-external-retrieval-program "www"
  4800.   "*Name of the external executable to run to retrieve URLs.")
  4801.  
  4802. (defvar url-external-retrieval-args '("-source")
  4803.   "*A list of arguments to pass to `url-external-retrieval-program' to
  4804. retrieve a URL by its HTML source.")
  4805.  
  4806. (defun url-retrieve-externally (url &optional no-cache)
  4807.   (if (get-buffer url-working-buffer)
  4808.       (save-excursion
  4809.     (set-buffer url-working-buffer)
  4810.     (set-buffer-modified-p nil)
  4811.     (kill-buffer url-working-buffer)))
  4812.   (set-buffer (get-buffer-create url-working-buffer))
  4813.   (let* ((args (append url-external-retrieval-args (list url)))
  4814.      (urlobj (url-generic-parse-url url))
  4815.      (type (url-type urlobj)))
  4816.     (if (or (member type '("www" "about" "mailto" "mailserver"))
  4817.         (url-file-directly-accessible-p urlobj))
  4818.     (url-retrieve-internally url)
  4819.       (url-lazy-message "Retrieving %s..." url)
  4820.       (apply 'call-process url-external-retrieval-program
  4821.          nil t nil args)
  4822.       (url-lazy-message "Retrieving %s... done" url)
  4823.       (if (and type urlobj)
  4824.       (setq url-current-server (url-host urlobj)
  4825.         url-current-type (url-type urlobj)
  4826.         url-current-port (url-port urlobj)
  4827.         url-current-file (url-filename urlobj)))
  4828.       (if (member url-current-file '("/" ""))
  4829.       (setq url-current-mime-type "text/html")))))
  4830.  
  4831. (defconst weekday-alist
  4832.   '(("Sunday" . 0) ("Monday" . 1) ("Tuesday" . 2) ("Wednesday" . 3)
  4833.     ("Thursday" . 4) ("Friday" . 5) ("Saturday" . 6)
  4834.     ("Tues" . 2) ("Thurs" . 4)
  4835.     ("Sun" . 0) ("Mon" . 1) ("Tue" . 2) ("Wed" . 3)
  4836.     ("Thu" . 4) ("Fri" . 5) ("Sat" . 6)))
  4837.  
  4838. (defconst monthabbrev-alist
  4839.   '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6)
  4840.     ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))
  4841.   )
  4842.  
  4843. (defun url-get-normalized-date (&optional specified-time)
  4844.   ;; Return a 'real' date string that most HTTP servers can understand.
  4845.   (require 'timezone)
  4846.   (let* ((raw (if specified-time (current-time-string specified-time)
  4847.         (current-time-string)))
  4848.      (gmt (timezone-make-date-arpa-standard raw
  4849.                         (nth 1 (current-time-zone))
  4850.                         "GMT"))
  4851.      (parsed (timezone-parse-date gmt))
  4852.      (day (cdr-safe (assoc (substring raw 0 3) weekday-alist)))
  4853.      (year nil)
  4854.      (month (car
  4855.          (rassoc
  4856.           (string-to-int (aref parsed 1)) monthabbrev-alist)))
  4857.      )
  4858.     (setq day (or (car-safe (rassoc day weekday-alist))
  4859.           (substring raw 0 3))
  4860.       year (aref parsed 0))
  4861.     ;; This is needed for plexus servers, or the server will hang trying to
  4862.     ;; parse the if-modified-since header.  Hopefully, I can take this out
  4863.     ;; soon.
  4864.     (if (and year (> (length year) 2))
  4865.     (setq year (substring year -2 nil)))
  4866.  
  4867.     (concat day ", " (aref parsed 2) "-" month "-" year " "
  4868.         (aref parsed 3) " " (or (aref parsed 4)
  4869.                     (concat "[" (nth 1 (current-time-zone))
  4870.                         "]")))))
  4871.  
  4872. ;;;###autoload
  4873. (defun url-cache-expired (url mod)
  4874.   "Return t iff a cached file has expired."
  4875.   (if (not (string-match url-nonrelative-link url))
  4876.       t
  4877.     (let* ((urlobj (url-generic-parse-url url))
  4878.        (type (url-type urlobj)))
  4879.       (cond
  4880.        (url-standalone-mode
  4881.     (not (file-exists-p (url-create-cached-filename urlobj))))
  4882.        ((string= type "http")
  4883.     (if (not url-standalone-mode) t
  4884.       (not (file-exists-p (url-create-cached-filename urlobj)))))
  4885.        ((not (fboundp 'current-time))
  4886.     t)
  4887.        ((member type '("file" "ftp"))
  4888.     (if (or (equal mod '(0 0)) (not mod))
  4889.           (return t)
  4890.         (or (> (nth 0 mod) (nth 0 (current-time)))
  4891.         (> (nth 1 mod) (nth 1 (current-time))))))
  4892.        (t nil)))))
  4893.  
  4894. (defun url-retrieve-internally (url &optional no-cache)
  4895.   (if (get-buffer url-working-buffer)
  4896.       (save-excursion
  4897.     (set-buffer url-working-buffer)
  4898.     (erase-buffer)
  4899.     (kill-all-local-variables)
  4900.     (make-local-variable 'emx-binary-mode)
  4901.     (setq url-current-can-be-cached (not no-cache)
  4902.           emx-binary-mode t)    ; Don't do any CRLF->LF in OS/2
  4903.     (set-buffer-modified-p nil)))
  4904.   (let* ((urlobj (url-generic-parse-url url))
  4905.      (type (url-type urlobj))
  4906.      (url-using-proxy (and
  4907.                (if (assoc "no_proxy" url-proxy-services)
  4908.                    (not (string-match
  4909.                      (cdr
  4910.                       (assoc "no_proxy" url-proxy-services))
  4911.                      url))
  4912.                  t)
  4913.                (not
  4914.                 (and
  4915.                  (string-match "file:" url)
  4916.                  (not (string-match "file://" url))))
  4917.                (cdr (assoc type url-proxy-services))))
  4918.      (handler nil)
  4919.      (original-url url)
  4920.      (cached nil)
  4921.      (tmp url-current-file))
  4922.     (if url-using-proxy (setq type "proxy"))
  4923.     (setq cached (url-is-cached url)
  4924.       cached (and cached (not (url-cache-expired url cached)))
  4925.       handler (if cached 'url-extract-from-cache
  4926.             (car-safe
  4927.              (cdr-safe (assoc type url-registered-protocols))))
  4928.       url (if cached (url-create-cached-filename url) url))
  4929.     (save-excursion
  4930.       (set-buffer (get-buffer-create url-working-buffer))
  4931.       (make-local-variable 'emx-binary-mode)
  4932.       (setq url-current-can-be-cached (not no-cache)
  4933.         emx-binary-mode t))        ; Don't do any CRLF->LF in OS/2
  4934.     (if (and handler (fboundp handler))
  4935.     (funcall handler url)
  4936.       (set-buffer (get-buffer-create url-working-buffer))
  4937.       (setq url-current-file tmp)
  4938.       (erase-buffer)
  4939.       (insert "<title> Link Error! </title>\n"
  4940.           "<h1> An error has occurred... </h1>\n"
  4941.           (format "The link type <code>%s</code>" type)
  4942.           " is unrecognized or unsupported at this time.<p>\n"
  4943.           "If you feel this is an error, please "
  4944.           "<a href=\"mailto://" url-bug-address "\">send me mail.</a>"
  4945.           "<p><address>William Perry</address><br>"
  4946.           "<address>" url-bug-address "</address>")
  4947.       (setq url-current-file "error.html"))
  4948.     (if (and
  4949.      (not url-be-asynchronous)
  4950.      (get-buffer url-working-buffer))
  4951.     (progn
  4952.       (set-buffer url-working-buffer)
  4953.       (if (not url-current-object)
  4954.           (setq url-current-object urlobj))
  4955.       (url-clean-text)))
  4956.     (cond
  4957.      ((equal type "wais") nil)
  4958.      ((and url-be-asynchronous (not cached) (equal type "http")) nil)
  4959.      ((not (get-buffer url-working-buffer)) nil)
  4960.      ((and (not url-inhibit-mime-parsing)
  4961.        (or cached (url-mime-response-p t)))
  4962.       (or cached (url-parse-mime-headers nil t))))
  4963.     (if (and (or (not url-be-asynchronous)
  4964.          (not (equal type "http")))
  4965.          (not url-current-mime-type))
  4966.     (if (url-buffer-is-hypertext)
  4967.         (setq url-current-mime-type "text/html")
  4968.       (setq url-current-mime-type (mm-extension-to-mime
  4969.                       (url-file-extension
  4970.                        url-current-file)))))
  4971.     (if (and url-automatic-caching url-current-can-be-cached)
  4972.     (save-excursion
  4973.       (url-store-in-cache url-working-buffer)))
  4974.     (if (not (string-match "^about:" original-url))
  4975.     (let ((last-time (url-have-visited-url original-url)))
  4976.       (if (not last-time)
  4977.           (setq url-global-history-completion-list
  4978.             (cons (cons original-url
  4979.                 (if url-current-time-string-has-args
  4980.                     (current-time)
  4981.                   (current-time-string)))
  4982.               url-global-history-completion-list))
  4983.         (setcdr last-time (if url-current-time-string-has-args
  4984.                   (current-time)
  4985.                 (current-time-string))))))
  4986.     cached))
  4987.  
  4988. ;;;###autoload
  4989. (defun url-retrieve (url &optional no-cache expected-md5)
  4990.   "Retrieve a document over the World Wide Web.
  4991. The document should be specified by its fully specified
  4992. Uniform Resource Locator.  No parsing is done, just return the
  4993. document as the server sent it.  The document is left in the
  4994. buffer specified by url-working-buffer.  url-working-buffer is killed
  4995. immediately before starting the transfer, so that no buffer-local
  4996. variables interfere with the retrieval.  HTTP/1.0 redirection will
  4997. be honored before this function exits."
  4998.   (url-do-setup)
  4999.   (if (and w3-running-FSF19 url)
  5000.       (set-text-properties 0 (length url) nil url))
  5001.   (let ((status (url-retrieve-internally url no-cache)))
  5002.     (if (and expected-md5 url-check-md5s)
  5003.     (let ((cur-md5 (md5 (current-buffer))))
  5004.       (if (not (string= cur-md5 expected-md5))
  5005.           (and (not (funcall url-confirmation-func
  5006.                  "MD5s do not match, use anyway? "))
  5007.            (error "MD5 error.")))))
  5008.     status))
  5009.  
  5010. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  5011. ;;; How to register a protocol
  5012. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  5013. (defun url-register-protocol (protocol &optional retrieve expander defport)
  5014.   "Register a protocol with the URL retrieval package.
  5015. PROTOCOL is the type of protocol being registers (http, nntp, etc),
  5016.          and is the first chunk of the URL.  ie: http:// URLs will be
  5017.          handled by the protocol registered as 'http'.  PROTOCOL can
  5018.          be either a symbol or a string - it is converted to a string,
  5019.          and lowercased before being registered.
  5020. RETRIEVE (optional) is the function to be called with a url as its
  5021.          only argument.  If this argument is omitted, then this looks
  5022.          for a function called 'url-PROTOCOL'.  A warning is shown if
  5023.          the function is undefined, but the protocol is still
  5024.          registered.
  5025. EXPANDER (optional) is the function to call to expand a relative link
  5026.          of type PROTOCOL.  If omitted, this defaults to
  5027.          `url-default-expander'
  5028.  
  5029. Any proxy information is read in from environment variables at this
  5030. time, so this function should only be called after dumping emacs."
  5031.   (let* ((protocol (cond
  5032.             ((stringp protocol) (downcase protocol))
  5033.             ((symbolp protocol) (downcase (symbol-name protocol)))
  5034.             (t nil)))
  5035.              
  5036.      (retrieve (or retrieve (intern (concat "url-" protocol))))
  5037.      (expander (or expander 'url-default-expander))
  5038.      (cur-protocol (assoc protocol url-registered-protocols))
  5039.      (urlobj nil)
  5040.      (cur-proxy (assoc protocol url-proxy-services))
  5041.      (env-proxy (or (getenv (concat protocol "_proxy"))
  5042.             (getenv (concat protocol "_PROXY"))
  5043.             (getenv (upcase (concat protocol "_PROXY"))))))
  5044.  
  5045.     (if (not protocol)
  5046.     (error "Invalid data to url-register-protocol."))
  5047.     
  5048.     (if (not (fboundp retrieve))
  5049.     (message "Warning: %s registered, but no function found." protocol))
  5050.  
  5051.     ;; Store the default port, if none previously specified and
  5052.     ;; defport given
  5053.     (if (and defport (not (assoc protocol url-default-ports)))
  5054.     (setq url-default-ports (cons (cons protocol defport)
  5055.                       url-default-ports)))
  5056.     
  5057.     ;; Store the appropriate information for later
  5058.     (if cur-protocol
  5059.     (setcdr cur-protocol (cons retrieve expander))
  5060.       (setq url-registered-protocols (cons (cons protocol
  5061.                          (cons retrieve expander))
  5062.                        url-registered-protocols)))
  5063.  
  5064.     ;; Store any proxying information - this will not overwrite an old
  5065.     ;; entry, so that people can still set this information in their
  5066.     ;; .emacs file
  5067.     (cond
  5068.      (cur-proxy nil)            ; Keep their old settings
  5069.      ((null env-proxy) nil)        ; No proxy setup
  5070.      ;; First check if its something like hostname:port
  5071.      ((string-match "^\\([^:]+\\):\\([0-9]+\\)$" env-proxy)
  5072.       (setq urlobj (url-generic-parse-url nil)) ; Get a blank object
  5073.       (url-set-type urlobj "http")
  5074.       (url-set-host urlobj (url-match env-proxy 1))
  5075.       (url-set-port urlobj (url-match env-proxy 2)))
  5076.      ;; Then check if its a fully specified URL
  5077.      ((string-match url-nonrelative-link env-proxy)
  5078.       (setq urlobj (url-generic-parse-url env-proxy))
  5079.       (url-set-type urlobj "http")
  5080.       (url-set-target urlobj nil))
  5081.      ;; Finally, fall back on the assumption that its just a hostname
  5082.      (t
  5083.       (setq urlobj (url-generic-parse-url nil)) ; Get a blank object
  5084.       (url-set-type urlobj "http")
  5085.       (url-set-host urlobj env-proxy)))
  5086.  
  5087.      (if (and (not cur-proxy) urlobj)
  5088.      (progn
  5089.        (setq url-proxy-services
  5090.          (cons (cons protocol (url-recreate-url urlobj))
  5091.                url-proxy-services))
  5092.        (message "Using a proxy for %s..." protocol)))))
  5093.  
  5094. (require 'urlauth)
  5095. (provide 'url)
  5096.